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B00MAP2  COMPUTER  PROGRAM  FOR  SONIC  BOOM  RESEARCH: 
PROGRAM  MAINTENANCE  MANUAL 


1 . 0  GENERAL 
1.1  Purpose 

The  objective  of  writing  this  Program  Maintenance  Manual  is 
to  provide  the  maintenance  programmer  personnel  with  the 
information  necessary  to  effectively  maintain  the  software. 


1.2  Program  History  and  Overview 

The  major  purpose  of  the  BOOMAP2  and  the  accompanying  MOAOPS 
programs  is  to  extract  and  analyze  information  from  the  Tactical 
Air  Crew  Combat  Training  System/Air  Combat  Maneuvering 
Instrumentation  (TACTS/ACMI)  system  installed  at  various  combat 
training  military  operating  areas.  This  information  is  then  used 
to  predict  the  location  and  magnitude  of  sonic  boom  overpressures 
on  the  ground  in  the  vicinity  of  supersonic  flights. 

Real  time  flight  information  is  transmitted  to  the 
TACTS/ACMI  systems  on  the  ground.  Among  the  data  is  real  time 
information  on  aircraft  position,  velocity  and  acceleration, 
updated  at  intervals  of  100  to  200  milliseconds.  The  MOAOPS 
program  extracts  these  data  for  the  sonic  boo..i  analysis  from  the 
tapes  at  approximately  1.5  second  intervals  in  order  to  minimize 
both  the  time  taken  to  read  the  tapes  and  the  quantity  of 
information  to  be  stored. 

The  MOAOPS  program  is  in  two  parts:  a  data  extraction 
program  EXTRCT,  and  an  index  deletion  and  modification  program 
DELETE.  The  data  extraction  program  reads  the  ACMI  tapes, 
extracting  relevant  information  and  appending  this  information  to 
either  a  new  or  existing  database.  This  library  file  accumulates 
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the  information  from  all  the  mission  tapes  analyzed.  The  library 
file  is  indexed  so  that  a  particular  mission,  aircraft  type,  etc. 
can  be  accessed  by  the  sonic  boom  analysis  programs. 

The  B00MAP2  data  analysis  program  accesses  the  MOAOPS 
library  tapes  as  selected  by  the  user.  The  data  analysis  program 
produces  statistical  and  graphical  output  describing  the  aircraft 
positions  parameters  as  various  measures  of  predicted  boom 
strength.  The  BOOMAP2  program  produces  tabular  output  of  various 
statistics  that  are  sent  directly  to  a  line  printer.  In 
addition,  for  those  situations  where  focused  sonic  booms  are 
produced,  individual  plots  of  the  maximum  overpressures  together 
with  other  technical  information  are  produced  in  the  form  of  a 
"scratch  pad".  These  "scratch  pads"  can  be  plotted  for  each 
situation  in  which  focused  booms  occur. 

When  a  mission  is  selected  from  the  MOAOPS  Library  and  used 
as  input  to  the  BOOMAP2  computer  program,  the  rays  traced  by 
BOOMAP2  are  saved  in  the  RAYS  Library.  If  that  same  mission  is 
then  selected  at  a  future  time,  the  necessary  ray  information  is 
recalled  from  the  library  thus  saving  substantial  computer  time. 

To  produce  graphic  output,  B00MAP2  creates  a  file  which  is 
compatible  with  California  Computer  Products'  (CALCOMP)  General 
Purpose  Contouring  Program  (GPCP  II)  (Reference  1) .  GPCP  II 
reads  this  file  and  generates  the  necessary  plotter  directives  to 
produce  hard  copy  graphic  output. 

The  user  controls  the  database  subset  to  be  extracted  from 
the  MOAOPS  Library  through  the  use  of  an  input  data  file. 

Through  this  file,  the  user  specifies:  a)  the  name(s)  of  the  MOA 
ranges  to  be  considered;  b)  mission  names  or  dates;  c)  bounding 
times  of  day;  d)  aircraft  types  (specific  tail  numbers  optional) . 
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Users  also  specify  the  desired  output  products.  These 

include : 

1.  A  statistical  summary  of  position,  speed,  and  boom  scrength 
variables.  This  summary  includes  distribution  functions  of 
range  x-coordinates  and  y-coordinates,  and  the  aircraft 
z-coordinate  (height  above  the  range),  all  in  feet.  It  also 
includes  a  distribution  function  of  effective  height  (h6) . 
Distribution  functions  of  Mach  number,  cutoff  Mach  number, 
and  effective  Mach  number  are  also  presented.  Estimated 
boom  strength  distribution  functions  include  peak 
overpressure  (in  pounds  per  square  foot) ,  the  peak 
overpressure  (in  dB,  re:  20  microPascals) ,  the  C-weighted 
sound  exposure  level  (in  dB) ,  and  the  A-weighted  sound 
exposure  level  (in  dB) .  The  estimated  boom  strength  are 
those  calculated  directly  below  the  extended  aircraft  flight 
trajectory  using  Carlson's  Simplified  Sonic  Boom  Prediction 
Model.  Also  included  are  root  mean  square  values  for 
effective  height,  Mach  number,  effective  Mach  number,  and 
cutoff  Mach  number. 

2.  A  flight  track  map  depicting  ground  projections  of  flight 
paths  during  supersonic  activity. 

3.  A  flight  track  map  depicting  ground  projections  of  flight 
paths  during  sonic  boom  producing  activity. 

4 .  A  noise  contour  map  of  average  C-weighted  sound  exposure 
levels  (CSEL) . 

5.  A  noise  contour  map  of  C-weighted  day-night  average  levels 
( CLDN) .  The  map  requires  input  of  the  reference  number  of 
daytime  operations  which  is  used  to  convert  CSEL  to  CLDN. 

6.  A  noise  contour  map  of  flight-averaged  peak  over  pressures 
in  pounds  per  square  foot,  in  OASPL  or  CSEL. 
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7.  A  map  showing  geographic  location  of  maximum  overpressures 

due  to  focused  sonic  booms . 

The  functional  relationship  between  major  program  elements 
is  shown  in  Figure  1.  Information  on  executing  the  MOAOPS 
programs  can  be  found  in  Reference  2.  This  manual  discusses  the 
maintenance  of  the  B00MAP2  program  and  associated  graphics 
packages.  A  technical  discussion  of  the  algorithms  is  provided 
in  Reference  3.  A  user's  and  computer  operator's  manual  is 
provided  in  Reference  4 . 

1.3  Terms  and  Abbreviations 

In  this  report,  overpressure  will  typically  mean  the 
"magnitude"  of  the  sonic  boom  at  a  given  point  expressed  in  terms 
of  the  maximum  overpressure  in  pounds  per  square  foot  (psf)  or  in 
terms  of  the  overall  sound  pressure  level  (OASPL)  in  dB,  or  in 
terms  of  the  C-weighted  sound  exposure  level  (CSEL)  in  dB. 

Program  options  allow  a  choice  of  either  of  these  three  metrics 
for  the  contour  presentations. 

Except  as  noted  in  the  separate  routines  all  units  are  in 
meters,  seconds,  degrees,  and  pascals.  Atmospheric  pressures  in 
the  traps  routines  are  millibars. 
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Figure  1.  Functional  Relationship  Between  Elements  of  B00MAP2  Computer  Program 
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2.0  SYSTEM  DESCRIPTION 

2.1  Functional  Overview  (Figure  2) 

The  main  routine,  BOOMAP2 ,  is  responsible  for  the  input  of 
user  directives  and  flight  information  from  the  MOAOPS  library. 
It  also  outputs  a  file  with  the  directives  for  the  plotting 
routines.  Although  the  plotting  routines  require  a  separate  job 
step,  BOOMAP2  must  be  run  in  order  to  create  this  file.  The  ray 
tracing  routines  are  called  from  B00MAP2 .  These  consist  of 
routines  to  trace  the  actual  rays,  calculate  the  location  of  a 
focus,  and  calculate  the  aging  of  the  signatures. 

2.2  Relationship  and  Description  of  Subroutines 

2.2.1  Main  Program  (Figure  3) 

2. 2. 1.1  BOOMAP2 

BOOMAP2  calls  the  parser,  which  interprets  the  user 
directives,  and  processes  the  information  accordingly.  It  calls 
the  routines  that  set  up  the  tables  which  are  necessary  for  the 
TRAPS  routines.  It  then  reads  in  a  flight  track  and  outputs 
those  portions  which  are  supersonic  (Unit  3)  and  which  are  boom 
producing  (Unit  4)  for  the  plotting  routines.  It  then  calls 
RTRACE  to  calculate  the  overpressures  on  the  ground.  BOOMAP2 
also  does  a  statistical  summary  of  all  of  the  flights  requested 
in  one  run.  Units  are  feet,  and  psf. 

2. 2. 1.2  RNGALT 

Given  a  site,  RNGALT  returns  the  mean  altitude  of  that 
Units  are  feet. 


site. 


B00MAP2 


Overview  of  B00MAP2  Routines 


B00MAP2 
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2. 2. 1.3  RNGLL 

RNGLL,  when  supplied  with  a'  site,  returns  the  latitude  and 
longitude. 

2.2. 1.4  SOUND 

SOUND  returns  the  local  speed  of  sound  in  feet/second  at  a 
given  altitude.  It  uses  the  utility  routines  FNDLYR  and  GETLYR. 

2. 2. 1.5  STOREC 

STOREC  saves  the  data  necessary  for  the  plotting  routines. 
The  data  are  saved  on  a  temporary  file  (Unit  39) . 

2.2.2  Input  Routines  (Figure  4) 

2. 2. 2.1  LEXPACK 

This  package  is  used  to  perform  the  lexical  analysis 
necessary  for  parsing.  The  purpose  for  combining  these 
procedures  into  a  package  is  to  reduce  the  scope  of  data 
communication  to  the  subroutines  contained  within  the  package. 


2. 2. 2. 1.1  GETLINE 


This  subroutine  is  used  to  fill  the  input  buffer  with  one 
line  of  input  data  from  INFILE.  The  line  of  code  is  then  echoed 
to  the  output  file,  LSTFILE.  When  the  end  of  file  is  reached, 
the  flag  ENDFLAG  is  set  to  true. 

2. 2. 2. 1.2  GETCHR 

This  function  subroutine  is  used  to  return  the  current 
character  from  the  input  buffer. 


BOOMAP2 


Figure  4.  Input  Routines 
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2. 2. 2. 1.3  ADDCHR 

This  subroutine  is  used  to  concatenate  the  given  character 
with  the  token  string  being  built.  The  length  of  the  string 
stored  in  TKNLEN  is  also  incremented  by  one  representing  the 
current  length  of  the  token  string. 

2. 2. 2. 1.4  GETOKEN 

This  subroutine  will  lexically  analyze  an  input  stream  of 
characters,  returning  the  string  composing  the  token,  the  length 
of  the  string,  and  a  token  value. 


2. 2. 2. 2  PRSFACK 

This  package  is  used  to  perform  the  parsing  of  the  source 
file  INFILE.  The  method  is  a  simple  table  driven  parse.  The 
parse  table  is  initialized  in  the  block  data  subroutine  PRSDATA . 
The  parse  table  consists  of  the  state  transitions  for  input 
tokens.  Each  time  an  input  token  is  returned  by  LEXPACK\GETOKEN , 
subroutine  PRSPACK\LOOKUP  is  called  to  determine  the  next  state 
to  go  to  by  referencing  the  parse  table  with  the  current  state 
versus  the  current  input  token  value.  Program  execution  then 
transfers  to  a  statement  label  representing  that  state,  where 
various  semantic  actions  are  performed  to  store  the  information 
in  internal  data  structures. 

2. 2. 2. 2.1  LDATE 


This  function  subroutine  is  used  to  check  if  a  certain  part 
(i.e.,  MONTH,  DAY,  YEAR)  is  legal  according  the  integer  bounds 
pertaining  to  that  part  of  the  date. 
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2. 2. 2. 2. 2  LTIME 

This  subroutine  function  is  used  to  test  if  the  time 
specified  is  within  the  military  bounds  of  0001-2400  hours. 

2. 2. 2. 2. 3  LOOKUP 

This  subroutine  is  used  to  access  the  parsing  table  based  on 
the  current  input  token  value  and  the  current  state  of  the 
parser.  The  current  state  of  the  parser  is  updated  and  then  an 
alternate  return  is  processed  based  on  the  current  state  of  tha 
parser. 

2. 2. 2. 2. 4  PARSE 

This  subroutine  is  used  to  parse  the  input  file  INFILE  by 
means  of  a  table-driven  parser.  Upon  reaching  the  current  state 
of  the  parser  various  semantic  actions  are  performed  to  store  the 
data  in  INFILE  in  internal  data  structures  for  later  use. 

2. 2. 2. 3  SCHPACK 

This  package  is  used  to  perform  the  process  of  searching  the 
data  tables  created  during  the  parse  stage.  This  search  is  used 
to  find  records  of  subsonic  and  supersonic  flight  data  records  in 
the  library  file  by  finding  their  location  through  the  use  of  an 
index  file.  This  index  file  is  similar  to  a  card  catalog.  ( 

2. 2. 2. 3.1  FILBUF 

This  function  subroutine  is  used  to  read  in  one  record  from  < 

the  INDEX  FILE.  If  there  are  no  more  records,  the  flag  ENDRECS 
is  set  TRUE. 


i 
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2. 2. 2. 3. 2  STRMCH 

This  function  subroutine  is  used  to  see  if  an  input  string 
matches  any  string  in  the  current  row  of  an  input  table.  If 
'ALL'  is  found  then  the  search  is  considered  successful. 

2. 2. 2. 3. 3  INTMCH 

This  function  subroutine  is  used  to  test  if  an  integer 
passed  in  matches  an  integer  in  the  current  row  of  the  table 
passed  in.  If  '9999'  is  found  then  the  test  is  considered 
successful . 

2. 2. 2. 3. 4  GETREC/GETINX 

These  subroutines  are  used  to  search  the  index  file 
according  to  the  user  specifications  stored  during  the  parse 
stage.  When  invoked  these  subroutines  will  read  records  from  the 
index  file  until  a  match  is  found.  When  a  match  is  found  the 
subroutine  will  return  the  starting  record  number  and  the  number 
of  records  occurring  after  the  starting  record.  If  a  match  is 
not  found  then  the  end  of  record  flag  ENDRECS  is  set  true. 

2.2.3.  Ray  Tracing  Driver  Routines  (Figure  5) 

2. 2. 3.1  RTRACE 


This  is  the  initial  driver  for  the  ray  tracing  routines. 
RTRACE  calls  the  routines  that  break  the  flight  track  up  into 
segments,  create  the  splines,  do  maneuver  screening  and  phi  angle 
selection,  and  do  the  ray  tracing.  The  flight  track  information 
is  converted  from  feet  to  meters  before  it  is  processed.  (Note: 
All  routines  for  Ray  Tracing  are  in  meters.) 
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2. 2. 3. 2  SPLINE 

This  routine  computes  the  matrix  for  finding  the 
coefficients  of  a  cubic  spline  through  a  set  of  data.  The  system 
is  then  solved  to  obtain  the  second  derivative  values.  Using  the 
second  derivatives  the  spline  coefficients  are  calculated. 

2. 2. 3. 3  GETSEG 

GETSEG  divides  the  flight  into  segments  where  the  points  are 
above  the  critical  Mach  number.  The  first  two  and  the  last  two 
points  of  a  segment  can  be  below  critical,  which  is  done  in  order 
to  improve  the  spline  interpolation.  There  can  also  be 
subcritical  points  in  the  track;  however,  there  can  be  at  most 
only  5.5  seconds  between  critical  points.  If  there  is  a  4.5 
second  gap  between  data  points,  the  segment  is  also  terminated. 

It  passes  back  two  arrays  of  pointers  that  point  to  the  start  and 
end  of  each  flight  segment. 

2. 2. 3. 4  SCREEN 

SCREEN  calculates  the  matrix  of  phi  angles  that  rays  are  to 
be  traced  for  each  emission  time.  If  the  aircraft  is  below  1500 
feet  then  rays  are  traced  every  two  degrees.  Otherwise,  they  are 
traced  every  degree. 

2. 2. 3. 5  SORTPHI 

This  subroutine  puts  the  array  of  phi  angles  in  ascending 
order. 

2. 2. 3. 6  STORE 

This  routine  stores  the  aircraft  locations  and  the  ground 
coordinates  and  overpressures  of  the  boom  in  the  ray  library 
file  "CLIBRY".  (Meters , pascals . ) 
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2. 2. 3. 7  SIDATT 

SIDATT  retrieves  the  information  necessary  from  the  "CLIBRY" 
to  do  overpressure  extrapolation  at  the  sidelines  of  the  boom. 

2. 2. 3. 8  EXTRPR 

This  subroutine  is  designed  to  extrapolate  outside  the 
margin  of  the  last  ray  down  to  the  threshold  of  approximately 
80  dB.  It  performs  this  task  by  receiving  two  rays  and  three 
angles.  (If  the  last  ray  does  not  hit  the  ground  then  its 
termination  point  is  calculated  and  used  asr  the  last  ray) .  The 
last  and  next  to  the  last  rays  are  used  to  extrapolate  outside 
the  margin  to  calculate  the  new  ray's  termination  points  and 
overpressure . 

2. 2. 3. 9  FFUNC 

FFUNC  generates  F-Functions  for  the  various  aircraft  in  the 
table.  The  F-Function  is  generated  from  a  table  of  Ks  factors 
and  it  is  104  points  long.  If  the  aircraft  type  is  not  found  in 
the  table,  an  error  message  is  printed,  and  processing  for  that 
flight  is  aborted. 

2.2.3.10  LSQUAR 

This  routine  is  designed  to  get  the  acceleration  information 
from  the  cubic  spline  coefficients  and  calculate  quadratic 
coefficients  using  a  weighted  linear  least  squares  method. 

2.2.3.11  GAUSJR 

This  routine  does  a  Gauss-Jordan  reduction  and  a  determinate 
evaluation  of  a  matrix. 
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2.2.3.12  SORT 

SORT  uses  a  Heap  Sort  to  sort  the  input  array. 

2.2.3.13  RBRAYS 

RBRAYS  is  a  filter  used  at  the  end  of  processing  of  each 
time  hack.  It  checks  the  rays  and  removes  any  anomalous  ones 
from  the  database. 

2.2.4  Focal  Zone  Calculation  Routines  (Figure  6) 

2. 2. 4.1  FOCMAP 


Given  an  approximate  angle  where  the  maximum  over  pressure 
on  the  ground  will  occur,  FOCMAP  traces  rays  on  either  side  of 
that  angle  to  get  a  good  sampling  of  the  overpressures  on  the 
ground.  It  terminates  processing  in  a  given  direction  when  the 
focus  is  no  longer  between  +1000  and  -1500  feet  of  the  ground. 

2. 2. 4. 2  CSTGND 

CSTGND  identifies  the  phi  angle(s)  at  the  point(s)  when  a 
caustic  surface  intersects,  or  is  closest  to,  the  ground. 

2. 2. 4. 3  FOCUS 

FOCUS  locates  a  caustic  surface  and  its  relative  curvature 
at  the  ray  intersection.  It  calculates  an  initial  ray  tube  by 
tracing  three  other  rays  and  uses  this  bundle  to  calculate  the 
direction  in  which  to  trace  three  auxiliary  ray  tubas.  The 
initial  ray  and  the  auxiliary  tubes  are  used  to  map  out  the 
caustic  surface  in  space. 
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2. 2. 4. 4  FOCAL 

FOCAL  is  used  to  calculate  the  focal  zone  width  when  a  focus 
is  between  +1000  ft  and  -1500  ft  of  the  ground.  It  then 
determines  whether  the  ground  is  in  the  focal  zone  and  whether 
to  use  the  TRAPS  or  FOBOOM  signature  and  overpressure. 

2. 2. 4. 5  INTERP 

INTERP  does  a  linear  interpolation  between  two  points. 

2. 2. 4. 6  GETDLT 

To  get  the  delta  increment  for  the  phi  angles  to  be  traced 
in  a  caustic-ground  intersection,  GETDLT  takes  1/I0th  of  the 
delta  of  normal  ray  tracing. 

2.2.5  TRAPS  Input  Routines  (Figure  7) 

2. 2. 5.1  SETUP 


SETUP  sets  various  flags  for  TRAPS  ray  tracing.  It  also 
calls  the  atmospheric  table  routines. 

2. 2. 5. 2  ATMS IN 

ATMSIN  performs  overall  control  of  the  routines  written  to 
input  atmospheric  data.  It  merges  the  results  of  PTDHIN  and 
WINDIN  and  a  pre-selected  set  of  altitudes  at  which  ray-trace 
output  is  wanted.  It  then  uses  the  above  to  create  a  single 
overall  data  table  for  use  by  subroutines  AIR  and  RAYTRK. 

2. 2. 5. 3  PTDHIN  (This  routine  is  presently  used  to  set  up  a 
standard  atmosphere  table  only.) 
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PTDHIN  reads  the  RAOB  File.  It  converts  all  data  into 
Standard  International  (S.I.)  units,  interpolates  dewpoint  data 
|  as  needed  and  calculates  virtual  or  molecular  scale  temperatures 

from  the  temperature  and  dewpoint  data.  It  supplies 
hydrostatically  valid  height  or  pressure  data,  as  appropriate, 
and  returns  a  table  of  virtual  temperatures,  pressures,  and 
|  heights.  It  can  also  print  out  all  input  data,  together  with  the 

calculated  pressure  and  height  information  in  original  units  for 
comparison  with  other  sources. 

|  2 . 2 . 5 . 4  RAOBWK 

RAOBWK  is  called  by  PTDHIN  to  create  an  RAOB;  i.e.,  to 
calculate  from  the  given  temperatures1  and  pressures  the 
"thicknesses"  (i.e.,  height  of  the  column  of  air  between  each 
pair  of  pressure  levels)  and  then,  by  keeping  a  running  total  of 
"thicknesses",  calculate  heights.  Conversely,  if  given 
thickness,  it  calculates  the  pressure  drop. 

2. 2. 5. 5  WINDIN  (This  routine  is  currently  bypassed  to  produce  no 
winds. ) 

WINDIN  is  called  by  ATMS IN  to  read  the  WINDS  File  and 
convert  to  S.I.  units.  It  produces  an  internal  table  of  wind 
speeds,  directions,  and  "turning  rates"?  i.e.,  the  rate  of 
direction  change  with  height  between  the  levels  in  the  WINDS 
File.  The  turning  rate  is  provided  to  assist  AIR  in  linear 
interpolation  of  wind  direction;  it  has  the  sign  and  magnitude 
to  cause  the  smallest  rate  of  direction  change  meeting  the  given 
directions.  Where  the  wind  speed  is  zero  on  one  side  of  a  layer, 
the  turning  rate  is  taken  to  be  the  same  as  that  of  an  adjacent 


1  The  virtual  or  molecular-scale  temperature  is  the  temperature 
at  which  dry  air  of  mean  tropospheric  chemical  composition  would 
have  the  same  pressure-density  relationship  as  the  actual  air. 
It  is  the  appropriate  temperature  for  calculating  both 
thicknesses  and  sound  speeds. 
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layer.  The  routine  also  prints  out  the  speed  and  direction  data 
in  the  original  units  for  documentation. 

2.2.6  TRAPS  Ray  Tracing  Routines  (Figure  8) 

The  function  of  emitting  and  tracking  rays  from  aircraft  to 
ground  is  performed  by  the  Ray  Tracing  routines.  These  routines 
are  based  in  the  program  identified  in  Reference  5. 

2.2. 6.1  ACMOVE 

ACMOVE  interpolates  aircraft  track  coefficients  to  current 
value  of  emission  time.  It  computes  and  stores  in  COMMON  block 
the  position,  velocity,  acceleration,  and  jerk  of  the  aircraft, 
the  local  speed  of  sound  and  wind,  the  air  speed  and  its  rate  of 
change,  the  Mach  number  and  its  rate  of  change,  the  climb  and 
bank  angle  and  the  wing  loading,  and  the  direction  cosines  of  a 
ray  cone  coordinate  system  and  their  rates  of  change.  It  can 
also  print  out  the  information  on  the  aircraft  position  and 
motion,  both  in  an  airborne  reference  frame  and  a  ground 
reference  frame. 

2 . 2 . 6 . 2  TACMOV 

TACMOV  calls  acmove  and  saves  the  aircraft  state  vector  as 
required. 

2. 2. 6. 3  FILIMS 

Given  the  information  from  the  ACMOVE  subroutine,  and  the 
wind  velocity  and  speed  of  sound  at  the  ground,  FILIMS  computes 
the  limits  of  the  phi  angle  of  the  admittance  ellipse  for  the 
ground  level.  It  can  print  out  the  limiting  phi  angles  for  the 
arcs  inside  the  admittance  ellipse,  if  any. 
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2. 2. 6. 4  RAYORG 


For  each  emission  time  and  for  each  value  of  phi  lying 
within  the  admittance  ellipse,  RAYORG  computes  the  initial  values 
of  position,  ray  normals,  "frequencies”,  and  their  rates  of 
change.  It  sets  current  time  equal  to  emission  time.  The  rates 
of  change  are  with  respect  to  not  only  current  time,  but  also  to 
the  ray  parameters  of  phi  angle  and  of  emission  time.  If  ray 
trace  printing  is  selected,  it  prints  out  the  initial  ray  trace 
values. 

2. 2. 6. 5  RAYTRK 


From  the  initial  values  supplied  from  RAYORG,  RAYTRK  traces 
the  ray  to  the  ground  level  and  reflects  as  many  times  as 
necessary.  RAYTRK  has  been  modified  to  trace  the  ray  to  either 
a  caustic  or  2000  feet  below  the  ground  depending  on  the  value  of 
TRACE  selected.  It  controls  the  computation  of  the  change  in  not 
only  the  position  of  the  ray,  but  associated  terms  such  as  the 
ray  normals,  the  ray  tube  area  terms,  and  the  age(s) .  If  ray 
trace  printing  is  selected,  it  also  prints  a  record  of  position, 
ray  tube  area,  and  time  at  selected  altitudes. 

2. 2. 6. 6  RATES 

RATES  computes  the  local  rate  of  change  of  the  ray  position, 
the  ray  normals,  and  the  associated  derivations  with  respect  to 
the  ray  parameters  and  emission  time. 

2. 2. 6. 7  ADVANS 

ADVANS  utilizes  information  from  RATES  to  compute  the 
advance  in  current  time,  and  the  change  in  ray  position  and 
associated  variables  corresponding  to  it. 
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2. 2. 6. 8  RCRVIT 

When  a  tentative  advance  brings  the  ray  beyond  a  reversal 
layer,  RCRVIT  locates  the  exact  position  of  the  reversal  layer. 

2. 2. 6. 9  RECORD 

When  the  ray  has  been  traced  to  ground  in  a  selected  carpet, 
RECORD  will  record  the  location  and  all  the  associated  variables 
required  to  compute  signatures  on  a  temporary  file  (FORTRAN 
Unit  9) . 

2.2.6.10  ARTUBE 


ARTUBE  computes  the  Jacobian  defining  the  ray  tube  area. 

2.2.6.11  DIST 


DIST  computes  the  distance  between  two  points  in  space. 

2.2.6.12  RCSPCL 


RCSPCL  outputs  the  positions  and  times  for  each  "special 
point"  in  the  ray's  path.  "Special  points"  include  reversal 
layer  encounters,  ground  encounters,  and  the  encounters  with  the 
caustic  surfaces.  (This  routine  is  presently  unused.) 

2.2.7  Signature  Aging  Routines  (Figure  9) 

After  all  rays  have  been  traced,  it  is  the  task  of  the 
signature  aging  routines  to  perform  the  final  calculations  and 
determine  the  actual  overpressures  to  be  expected. 


TRAPS  Signature  Aging  Routines 
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2. 2. 7.1  SIGNUR 

SIGNUR  has  overall  control  of  the  aging  and  printout 
process.  For  each  ray  terminus  recorded  by  RECORD,  it  reads, 
interprets  and  prints  out  the  information  on  ray  tape, 
including  Mach  number  of  aircraft,  initiation  time,  phi  angle, 
location,  elevation  and  azimuth  of  the  ray  normals,  and  the 
conversion  factors  from  F-function  normalized  coordinates  to  time 
(TFACT)  and  pressure  (PFACT) .  It  combines  the  F-functions 
according  to  this  information  and  controls  the  evolution  of  the 
signature.  (Printout  has  been  inhibited.) 

2. 2. 7. 2  FREAD  (Presently  unused) 

FREAD  determines  whether  the  necessary  F-function  tables  are 
in  main  memory,  and  if  not,  reads  them  into  main  memory.  It 
enables  the  use  of  lift  and  area  coefficients  to  determine  the  F- 
function. 

2. 2. 7. 3  AGING 

AGING  shifts  the  abscissa  values  (phase)  of  the  F-functions 
according  to  the  age  value,  determines  the  total  area  of  the 
resulting  figure,  and  fits  discontinuities  as  appropriate.  It 
replaces  the  input  F-function  with  the  result. 

2. 2. 7. 4  HILBRT 

HILBRT  has  overall  responsibility  for  calculating  the 
Hilbert  Transform.  It  replaces  the  input  F-function,  as  modified 
by  AGING  and  possibly  containing  shocks,  by  its  Hilbert 
Transform.  It  computes  the  transform  at  a  selection  of  points 
determined  by  the  overall  structure  of  the  function,  which 
includes  a  set  of  points  exponentially  converging  to  each  shock 
(terminating  within  a  distance  of  the  shock  equal  to  6*10~7  times 
the  overall  scale  of  the  input  F-function) .  It  also  includes  a 
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set  of  points  which  are  centered  on  the  mean  abscissa  value  of 
the  input  F-function  and  which  are  spaced  at  increasing 
increments  to  cover  an  interval  several  times  the  abscissa  scale 
of  the  input  F-function. 

2. 2. 7. 5  CPVAL 

CPVAL  computes  the  value  of  the  integral  defining  the 
Hilbert  Transform,  as  a  Cauchy  Principal  Value,  at  each  point 
directed  by  HILBRT. 

2. 2. 7. 6  SORTEM 

SORTEM  sorts  the  values  calculated  by  HILBRT  and  CPVAL  into 
ascending  order  of  abscissa  values,  as  required  by  AGING. 

2. 2. 7. 7  SIGPRT 

SIGPRT  prints  out  the  final  signature,  as  directed  on  the 
CONTROL  File  cards.  (Printout  is  currently  inhibited.) 

2. 2. 7. 8  TSIGPT 

TSIGPT  sets  the  appropriate  variables  and  calls  SIGPRT. 

2. 2. 7. 9  FOCALP 

This  subroutine  applies  ’GILL  AND  SEEBASS '  (Reference  6) 
focused  shock  wave  solution  to  each  shock  in  a  sonic  boom  at  a 
caustic.  It  first  converts  the  input  signature  from  values  PP  at 
arbitrarily  spaced  XX  to  100  evenly  spaced  points.  Pressure 
positions  are  diddled  slightly,  but  no  more  than  half  of  one 
percent  of  the  signature  length.  The  focus  solution  is  applied 
to  each  shock.  The  published  signature  is  linearly  extrapolated 
until  zero,  space  permitting.  Space  not  permitting,  focus 
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solutions  are  carried  out  to  the  midpoints  between  successive 
shocks . 

NOTE:  The  units  used  in  this  routine  are  feet  and  PSF. 

2.2.7.10  CALSEL 

CALSEL  calculates  the  CSEL  from  the  signature,  which  is  done 
by  first  removing  the  shocks  from  the  input  pressure  array  and 
then  interpolating  the  signature  to  every  0.5  millisecond.  It 
then  passes  the  array  to  a  FFT  routine  and  the  CSEL  is  computed 
from  the  frequency  spectra. 

2.2.7.11  FFT 

FFT  calculates  a  multivariate  complex  Fourier  Transform. 

2.2.7.12  CURVE 


This  subroutine  fits  a  circle  through  a  set  of  points  and 
returns  the  radius  vector  and  curvature. 

2.2.7.13  FINDT 

FINDT  finds  a  point  on  a  ray  at  a  specific  time.  It  then 
sets  the  arrays  so  that  the  locations  on  each  ray  stored 
correspond  to  the  time  of  the  earliest  caustic. 

2.2.8  Utility  Routines  (Figure  10) 

These  utility  routines  are  called  from  various  subroutines 
throughout  the  code.  Some  of  these  routines  deal  with  physical 
problems  and  vector  arithmetic.  Others  are  used  by  TRAPS  for 
housekeeping  and  table  lookup. 
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2. 2. 8.1  AIR 

|  AIR  is  called  to  produce,  at  a  specified  altitude  within  a 

specified  layer,  the  values  of  the  speed  of  sound  and  wind 
velocity,  the  first  and  second  derivatives  of  those  quantities 
with  respect  to  height,  and  the  density  of  the  atmosphere.  It 
j  uses  linear  interpolation  of  wind  speed,  wind  direction,  and 

virtual  temperature,  with  respect  to  geopotential  height.  All 
other  quantities  are  derived  by  algebraic  manipulation  and  a 
hydrostatic  assumption. 

I 

2. 2. 8. 2  PHELEV 


Given  the  components  of  the  wave-number  vector,  PHELEV 
calculates  the  elevation  angle  of  the  normals  to  the  phase 
surfaces  of  the  wave. 

2. 2. 8. 3  PHAZIM 

Given  the  components  of  the  wave-number  vector,  PHAZIM 
calculates  the  azimuth  angle  of  the  normals  to  the  phase  surfaces 
of  the  wave. 

2  2.8.4  EAMENU 

Given  the  elevation  angle,  azimuth  angle,  and  magnitude  of  a 
vector,  EAMENU  calculates  the  east,  north,  and  upward  components 
of  that  vector. 

2. 2. 8. 5  UNITS 


Given  a  character  string  for  unit  type,  a  table  of  possible 
unit  names,  a  default  unit  index,  and  a  character  string,  UNITIS 
determines  the  appropriate  unit  index  or  prints  appropriate  error 
messages . 
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2.2.8. 6  TIMCVR 

If  TRACK  File  chose  HKMMSS  units,  TIMCVR  converts  hhmmss 
time  units  to  seconds  and  vice-versa.  Otherwise,  it  leaves  time 
units  unchanged. 

2. 2. 8. 7  GETLYR 

Given  a  numeric  value  and  a  pre-sorted  table  of  numeric 
values,  GETLYR  performs  a  binary  table  search  to  determine 
between  which  two  table  entries  the  given  value  is  located.  If 
the  given  numeric  value  is  not  covered  by  the  table,  a  non¬ 
standard  return  is  performed. 

2. 2. 8. 8  FNDLYR 

FNDLYR  defines  the  location  of  a  layer  in  the  atmosphere  in 
which  a  given  altitude  is  located.  It  sets  numeric  variables  to 
top  and  bottom  of  layer.  It  is  called  just  prior  to  calling  AIR 
by  all  routines  except  RAYTRK,  which  manages  layer  definition  for 
itself. 

2. 2. 8. 9  DOTP 


Function  DOTP  computes  the  dot  product  of  2  N-dimensional 
vectors . 

2.2.8.10  RNORM 

Function  RNORM  calculates  the  vector  norm. 

2.2.8.11  CROSS 


CROSS  calculates  the  cross  product  of  two  3-dimensional 
vectors . 
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2.2.8.12  UNIT 

UNIT  calculates  a  unit  vector  in  the  same  direction  as  the 
input  vector. 

2.2.8.13  MDOT 

MDOT  converts  zero  values  in  the  'STATS'  output  to  dots,  for 
easier  reading. 

2.2.8.14  SAVRAY 

Subroutine  SAVRAY  saves  the  ray  times,  locations,  and  ages 
at  each  mesh  step  in  a  temporary  array. 

2.2.8.15  SRTRAY 

SRTRAY  accepts  a  random  access  file  and  a  specified  field. 

It  then  sorts  the  random  access  file  on  the  selected  field  using 
a  heapsort  method. 

2.2.8.16  SORTRY 

SORTRY  accepts  a  two  dimensional  array  and  a  specified 
column  of  that  array.  It  then  sorts  the  array  on  the  selected 
column  using  a  heapsort  method. 

2.2.8.17  DDOTP 

Double  precision  function  DOTP  computes  the  dot  product  of 
2  N-dimensional  vectors. 

2.2.8.18  DRNORM 

Double  precision  function  RNORM  calculates  the  vector  norm. 
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2.2.8.19  DCROSS 

CROSS  calculates  the  cross  products  of  two  3 -dimensional 
double  precision  vectors. 

2.2.8.20  DUNIT 

UNIT  calculates  a  double  precision  unit  vector  in  the  same 
direction  as  the  input  vector. 

2.2.9  Graphics  Routines  (Figure  11) 

The  following  routines  are  used  to  initialize  the  needed 
variables,  open  the  necessary  files,  and  sort  the  data  on  a 
selected  field  in  order  to  generate  the  selected  graphical 
output . 


« 
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2 . 2 . 9 . 1  STOREC 

STOREC  reads  in  the  necessary  variables  stored  in  file 
HOLDVAR,  FORTRAN  unit  76,  to  select  the  specified  flight  tracks 
and  create  the  selected  output,  which  allows  the  BOOMAP2  program 
to  be  run  as  a  two-step  process.  This  routine  then  calls  PLOTDR 
to  invoke  the  plotting  routines. 


2 . 2 . 9 . 2  PLOTDR 

PLOTDR  opens  the  files  needed  to  produce  the  selected 
graphical  output.  It  then  calls  CONTUR,  CPBMTR ,  CPSSTR,  CPINIT, 
CPTERM,  and  SCRPAD  to  produce  the  selected  output. 

2 . 2 . 9 . 3  SCRHFL 


SCRHFL  is  designed  to  read  records  from  the  ray  library, 
CLIBRY  FORTRAN  unit  52,  and  create  a  temporary  file  called 
SCRCHFL,  Fortran  unit  32.  In  doing  so  the  routine  also  creates  a 
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temporary  file  called  HOLDF ,  FORTRAN  unit  34.  The  flight  tracks 
read  from  CLIBRY  are  stored  in  file  SCRCHFL  if  the  flight  track 
contains  caustic  rays.  If  a  flight  track  has  a  gap  of  4.5 
seconds  or  greater  it  is  broken  up  into  several  flight  segments. 
Each  has  a  scratch  pad  plot  generated  if  it  contains  caustic 
rays. 


2 . 2 . 9 . 4  CPBMTR 

CPBMTR  reads  in  the  boom  producing  flight  tracks  from 
FORTRAN  file  4  and  produces  a  plot  file,  TAPE11,  to  be  processed 
later  by  GPCP  II. 

2 . 2 . 9 . 5  CPSSTR 

CPSSTR  reads  in  the  supersonic  flight  tracks  from  file  three 
and  produces  a  plot  file,  TAPE11,  to  be  processed  later  by  GPCP 
II. 


2. 2. 9. 6  CPINIT 

This  routine  initializes  TAPE11  which  is  used  to  store  the 
GPCP  II  compatible  plot  files. 

2 . 2 . 9 . 7  CPTERM 

This  routine  is  used  to  close  file  eleven  which  contains  the 
plot  file  for  GPCP  II. 

2.2.10  Contouring  Routines  (Figure  12) 

The  following  routines  are  used  to  calculate  the  contour 
grid,  output  the  contour  plots,  and  to  output  the  supersonic  and 
boom-producing  flight  tracks. 
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2.2.10.1  CONTUR 

CONTUR  calls  GETINX  which  returns  pointers  to  the  ray 
database  for  a  selected  flight  track.  It  then  calls  SCRCHFL 
which  creates  the  scrchpad  file.  CONTUR  reads  in  ray  data  from 
CLIBRY,  FORTRAN  unit  52,  to  produce  temporary  file  TEMPFL , 

FORTRAN  unit  33.  TEMPFC  contains  the  rays,  sorted  on  termination 
time,  to  be  entered  into  the  contour  grid.  In  producing  file 
TEMPFL,  another  temporary  file  is  used  called  TMP2FL,  FORTRAN 
unit  35.  After  a  flight  track  is  processed,  CONTUR  calls  GRIDPW 
and  then  looks  for  another  flight  track  to  process.  When  all  the 
selected  flight  tracks  have  been  processed,  CONTUR  calls  CPCONT 
which  outputs  the  contour  grid  to  be  processed  by  GPCP  II . 

2.2.10.2  CPCONT 

CPCONT  accepts  a  grid  array  which  it  then  outputs  to  TAPE 11 
which  will  be  processed  later  by  GPCP  II  to  produce  the  selected 
contour  plots. 

2.2.10.3  GRIDPW 

GRIDPW  is  designed  to  read  data  from  file  TEMPFL,  FORTRAN 
unit  33,  that  was  created  by  CONTUR.  It  then  calculates  the 
slant  distance  from  the  aircraft  to  the  ray  termination  point. 
With  the  slant  distance  it  calculates  the  weights  for  each  of  the 
four  grid  points  closest  to  the  ray  termination.  It  then  adds 
these  values  to  the  scratch  array  and  increments  the  counter 
array.  It  then  calls  DIVARR  when  there  is  an  elapsed  time  of  4.5 
seconds . 

2.2.10.4  DIVARR 


This  routine  takes  the  scratch  array  and  divides  it  by  the 
counter  array  and  then  adds  it  to  the  master  array  which  is  later 
output  to  CPCONT. 
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2.2.11  Scratch  Pad  Routines  (Figure  13) 

The  following  routines  are  designed  to  set  up  the  file  used 
to  create  the  scratch  pad  plots,  select  the  proper  contour 
levels,  and  generate  the  scratch  pad  plots. 

2.2.11.1  SCRPAD 

SCRPAD  is  designed  to  read  in  data  from  the  file,  SCRCHFL, 
FORTRAN  unit  32,  created  in  SCRHFL.  It  then  calls  CCONVL, 

FNDCNT ,  CONPTS ,  PSETUP,  PLOTIT,  and  CLSPLT  to  output  the  scratch 
pad  plots.  It  also  calculates  the  area  for  each  contour  level. 
For  each  scratch  pad,  three  or  less  contour  levels  are  generated. 

2.2.11.2  CCONVL 

CCONVL  accepts  an  airay  of  pressures  which  it  converts  to 
either  PSF  or  dB.  It  also  selects  ten  contour  levels  which  will 
be  searched  for  in  the  other  routines. 

2.2.11.3  FNDCNT 

FNDCNT  accepts  three  arrays  for  each  time  hack  in  the  flight 
segment?  they  are  a  pressure  array  and  the  x  and  y  location  of 
the  pressure  value.  It  then  searches  for  four  or  less  points  in 
the  pressure  array  which  coincide  with  the  selected  contour 
level.  If  it  finds  a  point,  it  does  a  linear  interpolation  to 
find  the  approximate  x  and  y  locations  for  that  contour  level. 

2.2.11.4  CONPTS 


CONPTS  is  designed  to  connect  up  the  points  found  in  FNDCNT 
to  form  a  contour  level. 

1 
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Scratch  Pad  Routines 
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2.2.11.5  PSETUP 

PSETUP  sets  up  the  plot  page.  It  plots  the  aircraft  flight 
track,  flight  information,  flight  identification,  maximum 
overpressure  location,  range  center,  carpet  boom  level,  and  map 
annotation.  It  also  calculates  a  map  scale. 

2.2.11.6  PLOTIT 

PLOTIT  plots  the  contour  levels  one  at  a  time  and  puts  the 
area  and  level  of  the  contour  on  the  scratch  pad  plot. 

2.2.11.7  CLSPLT 

The  CLSPLT,  this  routine  is  designed  to  create  a  new  plot 
page  after  a  scratch  pad  plot  has  been  generated. 
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3 . 0  ENVIRONMENT 

3 . 1  Hardware 

The  B00MAP2  software  was  designed  to  execute  on  Control  Data 
Corporation  (CDC)  computers  using  the  NOS  2.4  operating  system. 
Access  to  California  Computer  Products  (CALCOMP)  General  Purpose 
Contouring  Program  (GPCP  II)  is  needed  to  do  contour  maps  and 
flight-track  maps.  CDC's  UNIPLOT  Library  is  needed  to  do  scratch 
pad  plots.  To  produce  all  plots  an  appropriate  pen  plotter  (that 
can  be  driven  by  both  GPCP  II  and  UNIPLOT)  must  be  attached  to 
the  computer  systems. 

3 . 2  Database 

3.2.1  Input  Index  and  Library  files 

These  two  input  files  contain  the  aircraft  flight 
information  necessary  for  the  ray  tracing  calculations. 

3. 2. 1.1  Index  File,  'INDEX' 

This  is  a  formatted,  direct  access  file.  It  contains  the 
mission  information  and  access  information  necessary  to  locate 
entries  in  the  flight  library  file  (Reference  2) . 

3. 2. 1.2  Library  File,  'LIBRY' 

This  is  a  formatted,  direct  access  file.  It  contains  the 
dynamic  database  for  each  aircraft  flying  each  mission 
(Reference  2) . 
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3.2.2  Output  Index  and  Library  Files 

There  are  two  files  used  for  the  storing  of  ray  information 
after  processing.  They  are  CLIBRY  and  CINDEX.  These  files  are 
accessed  by  the  plotting  programs  to  produce  focal  boom  plots  and 
full  contours. 

3.2.2. 1  Ray  Index  File,  'CINDEX' 

CINDEX  is  a  random  access  file  which  contains  the 
information  necessary  to  uniquely  identify  each  flight.  Each 
record  is  110  characters  long.  It  also  contains  the  addresses  in 
CLIBRY  for  the  rays  and  maximum  overpressure  records. 

First  record:  Format (110) 

110  NUMREC:  Number  of  records  in  the  file. 

Second  record  onwards:  Format (A16,  A8,  12,  A10,  18, 

18,  12,  A6 ,  A8 ,  110,  110,  110,  110,  LI) 

A16  Mission  name 

A8  Date  of  mission 

12  Site  number 

A10  Site  location 

18  Starting  time  of  the  mission 

18  Ending  time  of  the  mission 

12  Aircraft  type  number 

A6  Aircraft  type 

A8  Aircraft  tail  number 

110  Starting  record  of  the  corresponding  ray 
database  in  'CLIBRY'  file 
110  Total  number  of  ray  records 
110  Starting  record  of  maximum  overpressure 
records  in  'CLIBRY' 

110  Total  number  of  the  maximum  overpressure 
records 
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LI  Caustic  flag  set  true  if  there  are  any 
caustics  in  the  flight. 

The  range  times  are  in  the  form  Hour,  Minute,  Second,  1/100 
Second. 

3. 2. 2. 2  Ray  Library  File,  1 CLIBRY ' 

CLIBRY  contains  the  ray  information  for  all  of  the  flights. 
It  is  also  a  random  access  file  and  each  record  is  10  -  100 
characters  long.  Each  section  of  this  file  consists  of  three 
parts:  the  header  record,  the  ray  records,  and  the  maximum 
overpressure  records. 

In  addition  to  information  about  the  flight,  the  header 
record  also  contains  the  altitude  of  the  ground. 

The  ray  records  contain  all  of  the  pertinent  information 
about  the  rays  for  each  super  critical  time  analyzed.  The  flag 
at  the  start  of  each  record  contains  either  0,  21,  or  11.  A  zero 
indicates  that  these  overpressures  are  attenuated  at  the 
sidelines.  A  21  indicates  that  this  ray  has  a  focus  near  the 
ground  and  a  scratch  pad  plot  has  not  been  produced.  The  flag 
setting  of  11  indicates  that  the  ray  has  no  focus,  or  that  the 
focus  is  not  near  the  ground.  When  the  scratch  pad  plots  for 
this  flight  have  been  processed  the  21s  are  changed  to  11s. 

The  maximum  overpressure  records  contain  the  information 
about  the  ray  with  the  largest  overpressure,  for  each  time 
processed,  that  had  a  focus  near  the  ground. 
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First  record  :  Format (110) 

110  ENDREC:  Record  number  of  the  last  record  in 
the  file. 

For  each  aircraft,  for  each  mission  segment. 

Header  record:  Format (A16,  A8,  12,  A10,  A6,  A8,  F10.2) 

A16  Mission  name 

A8  Date  of  mission 

12  Site  number 

A10  Site  location 

A6  Aircraft  type 

A8  Aircraft  tail  number 

F10.2  Altitude  of  the  ground  in  meters 

Ray  records:  Format (12,  F8.2,  3F8.0,  F8 . 2 ,  2F8.0, 

F8.3,  F10.4,  F10.4,  F10.4) 

12  Processing  flag 
F8.2  Ray  emission  time  in  seconds 
3F8.0  Range  coordinates  (x,  y,  and  z)  of  the 
aircraft  in  meters 

F8.2  Ground  arrival  time  of  the  ray  in  seconds 
2F8.0  Ground  coordinates  of  the  ray  in  meters 
F8 . 3  Emission  phi  angle 
F10.4  Overpressure  in  pascals 
F10.4  SEL 

F10.4  Effective  aircraft  Mach  number 

Maximum  overpressure  record:  Format (F8. 2,  3F8.0, 

F8.2,  2F8.0,  F10.4,  F10.4,  F10.4) 
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F8.2  Ray  emission  time  in  seconds 
3F8.0  Range  coordinates  (x,  y,  and  z)  of  the 
aircraft  in  meters 

F8.2  Ground  arrival  time  of  the  ray  in  seconds 
2F8.0  Ground  coordinates  of  the  ray  in  meters 
F8.3  Emission  phi  angle 
F10.4  Overpressure  in  pascals 
F10.4  SEL 

F10.4  Overpressure  calculated  using  Carlson's 
method  in  PSF 
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4.0  PROGRAM  MAINTENANCE  PROCEDURES 

4 . 1  Conventions 

See  the  program  listings  for  a  detailed  description  of  the 
variables  associated  with  each  routine . 

4.2  Verification  Techniques 

Verification  of  the  code  was  accomplished  by  comparison  of 
the  output  with  that  of  the  TRAPS  and  FOBOOM  programs.  In 
comparison  with  TRAPS,  overpressures  differed  by  no  more  than  5%. 
These  differences  were  due  to  the  fact  that  TRAPS  and  BOOMAP2 
calculate  the  aircraft  vectors  using  different  interpolation 
methods.  The  differences  with  FOBOOM  were  slightly  larger,  about 
10%.  FOBOOM  cannot  calculate  overpressures  beyond  the  focus; 
therefore,  a  detailed  comparison  was  not  possible. 

4.3  Updating  Site  and  Aircraft  Information 

There  are  two  routines  that  define  site  altitude  and 
latitude  and  longitude  information.  They  are  GETALT  and  GETLL. 

To  add  another  site  to  the  program,  the  data  statements  in  these 
routines  must  be  modified  accordingly. 

The  subroutine  FFUNC  contains  the  aircraft  information.  In 
it  are  data  statements  for  aircraft  type,  a  Ks  value,  aircraft 
weight,  and  aircraft  length.  A  new  aircraft  type  may  be  added  to 
the  program  by  placing  the  appropriate  information  into  these 
data  statements  and  altering  the  dummy  values  at  the  end, 
accordingly. 

The  TRAPS  subroutine  FREAD  allows  the  user  to  input  lift  and 
area  factors  for  the  F-functions.  If  lift  and  area  inputs  are 
desired,  the  calls  to  FFUNC  must  be  replaced  with  calls  to  FREAD. 
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For  a  more  detailed  description  of  the  input  to  FREAD  see 
Reference  5. 
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c 


PROGRAM  BOOMAP2  (INPUT, OUTPUT, TAP£6*0UTPUT 
1  TAPES* INPUT) 


C 


c 

C  THE  BOOMAP2  PROGRAM  USES  RAY  TRACING  AND  FOCAL  ZONE  CALCULATION 
C  TECHNIQUES  TO  CALCULATE  THE  SONIC  OVERPRESSURES  OF  A  SUPERSONIC 
C  AIRCRAFT.  THE  ACTUAL  RAY  TRACING  ROUTINES  COME  FROM  THE  T.R.A.P.S 

C  PROGRAM  BY  OR.  ALBION  TAYLOR  AND  THE  FOCAL  ZONE  CALCULATIONS  WERE 

C  AOOAPTEO  FROM  THE  F0800M  PROGRAM  BY  KEN  PLOTKIN. 

C 


C 

C  FOR  MORE  INFORMATION  SEE 
C  8BN  REPORT  6488 

C  "BOCMAP2  COMPUTER  PROGRAM  FOR  SONIC  BOOM  RESEARCH: 
C  PROGRAM  USERS'  MANUAL  VOLUME  2  OF  3",  JANUARY  1986 
C 


C 

C  BOOMAP2  IS  UR I TEN  IN  ANSI  STANDARD  FORTRAN 77 
C  THE  "BOOM •MAP",  “PARSE",  AND  "LEXICAL"  PORTIONS  OF  THE  PROGRAM 
C  ARE  WRITTEN  BY  R.O.HORONJEFF  AND  B.B. LACEY, XONTECH, LOS  ANGELES, CA 
C  DECEMBER  1985 

C 

C  MODIFIED  MARCH  1986  -  INCLUDES  RANGE  CENTER  LATITUDE  &  LONGITUDE 
C 

C  THE  RAY  TRACING  DRIVER  "RTRACE"  AND  SUBSEQUENT  PROCESSING  ROUTINES 
C  ARE  WRITEN  BY  P.J.DAY  AND  T. REILLY,  XONTECH  INC.,  LOS  ANGELES,  CA 
C  MAY  1987 

C 

C  THE  CONTOURING  AND  PLOTTING  ROUTINES 

C  ARE  URITEN  BY  T. REILLY  AND  H. SE I OMAN , XONTECH  INC., LOS  ANGELES, CA 

C  MAY  1987 

C 

£***  ****■#*****»**»»«■***»«»*****+**  #'***■*'**«**  **»****■******■***■***■#******«' 

C 

COMMON  /GRID/  GRDXO,  XGS,  GRDXMX,  GRDYO,  YGS,  GRDYMX, 

1  LIMAXO,  LIMAYO,  LSMBXO,  LIMBYO, 

2  L1MAX1 ,  LIMAY1 ,  LIMBX1,  LIMBY1 
C 


COMMON  /STATS/  STATFG,  BOOMFG,  MACHFG,  CONTFG,  BOOMVL, 

MACHVL,  CONTVL(5,20),  CONTYP(S),  WIDTH,  FFT , 
SIGNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 


LOGICAL  LMFG,  LMCFL1,  LMCFLO,  PLYFG,  MRFG,  PERFG 
LOGICAL  STATFG,  MACHFG,  3CCMFG ,  CONTFG 
LOGICAL  RAYTRC,  SIGNAT,  FFT,  SCRPAD,  SCRPSF,  SCRALL 
LOGICAL  GPCPFL ,  GPCPMH,  GPCP8M,  GPCPCN,  RAYINX 

COMMON  /FL I GHT/NFP , FT IME , FX , FY , FZ , VX , VY , VZ , FMACH , CA 


DIMENSION  FT I ME ( 1 1 56 ) , FX( 1 1 56 ) , FY ( 1 1 56  > , FZ ( 1 1 56 ) 

DIMENSION  VX(1156),VY(1156),VZ(1156), FMACH (1156),CA(1156) 


DIMENSION  MX<52),  MY(52),  MZ{52),  MM(59>,  MMC(59),  MME<59) 
DIMENSION  MOPC59),  MLPK<79),  MLCE<79),  MLAE(79),  MHE(52> 
DIMENSION  MXY(52,52) 

DIMENSION  GR1DA<102,102),  GR1DBD0, 10),  GR1DT(10,10> 
CHARACTER  AMXY(52,52>,CBUF*4 

COMMON  /ACIDNT/  ACTYP 
CHARACTER’S  ACTYP 

COMMON  /ACUIEG/  ACWT 


COMMON  /INOEXR/  INOXR 


CHARACTER’IO 

SITELC,  TDATE,  TTIME,  LAT,  LONG 

CHARACTER* 16 

MNAME 

CHARACTER’8 

MOATE,  ACTA! L ,  STARTT,  ENOT 

CHARACTER’S 

ACTYPE 

CHARACTER’20 

10X,  IDY,  IDZ,  IOHE,  I DM,  IDMC, 

1 

1DLPK,  IDLCE ,  1DLAE 

CHARACTER’ 70 

TITLE 

C 

COMMON  /UNITS/  UTUN 1 T , HTUN I T 
CHARACTER’S  WTUN I T , HTUN I T 
C 

COMMON  /GROUND/  GLAYER , ZGRNO , CGRNO , UGRNO , VGRND , REFLFC 
INTEGER  GLAYER 
C 

REAL  MACH,  MACHVL 
INTEGER  CONTYP 
C 

C-  EQUIVALENCE  TO  SAVE  SPACE 
C 

EQUIVALENCE  (GRIDA( 1 , 1 ) , FT IME< 1 ) ) 

C 

C 

c 

C  GET  THE  TIME  ANO  DATE 

C 

C  TDATE  *  DATED 

C  TTIME  =  TIMED 

HTUN IT  *  'FT' 

UTUN IT  *  'KG' 


PI  =>  3.1415926535 
FTDELM  =  999999. 
TWOPI  =  2.0  *  PI 
STATFG  *  .FALSE. 
MACHFG  =  .FALSE. 
BOOMFG  =  .FALSE. 


CONTFG  *  .FALSE. 

RMSHE  *  0. 

RMSMN  *  0. 

RMSCMN  *  0. 

RHSEMN  *  0. 

DO  S  1^1,20 
DO  8  J=1 ,5 
a  CONTVL( J , I )  *  0. 

ZERO  THE  STATISTICAL  MATRICES 

DO  12  1*1, NX 
MWD  »  0 

12  MY(I)  «  0 

DO  13  1*1 ,NZ 

MHE  < I >  *  0 

13  MZCI)  *  0 

DO  14  1*1,  MM 

MM(  I  )  a  0 
MMC(I)  *  0 

14  MME(l)  *  0 

DO  15  1*1, NO 

15  MOP(I)  *  0 

DO  16  1*1, NL 

MLPRCI)  *  0 
MLCE( 1 5  *  0 

16  MLAE Cl >  a  0 
DO  17  I  a  1 ,  NX 
DO  17  J*1 ,  NY 

17  MXY(I,J)  =  0 

GET  USER  SUPPLIED  INPUT  DIRECTIVES 
CALL  PARSEITITLE,  PERFG) 

IF  (PERFG)  STOP  '  •*  INPUT  DIRECTIVE  SYNTAX  ERROR 

INITIALIZE  POINTERS  AND  COUNTERS 

FT INC  a  1.0 
NMTCH  a  0 
NSUP  a  0 
MSU6  a  0 
NBOOM  a  0 
LINCNT  a  0 
TSECS  a  o. 

TSEC8  *  o. 

NME  »  0 
NCE  a  0 
NMET  =  0 
NCET  =  0 


OPEN  INDEX  AND  LIBRARY  FILES 


OPEN  (1,  FILE*' 1NOEX1 ,  STATUSa'OLD1 ,  ACCESS*1 DIRECT1 , 
1  FORM* 1  FORMATTED 1 ,  RECL*98,  BLANK* 1  NULL 1 ) 

OPEN  <2,  FILE*1 LI8RY* ,  STATUSa'OLD1,  ACCESS* '0 1 RECT 1 , 
1  FORM* 1  FORMATTED 1 ,  RECL»70,  BLANK* ‘NULL  1 ) 

0PENC3,  FILE-* FI L3 1 > 

0PEN(4,  FILE*1 FIL41 ) 

0PEN(7,  FILE*1 FIL71 ) 

OPEN (12, FILE*1 F I  LI  2 1 5 
0PEN(20, FILE“'SIGNAT’ ) 


C 

C  OPEN  CONTOUR  INDEX  AND  LIBRARY  FILES 

C 

OPEN  (SI,  FILE-'CINDEX1,  STATUS* 1  UNKNOWN 1 ,  ACCESS* ‘DIRECT 1 
1  FORM* 1  FORMATTED 1 ,  RECL*110,  BLANK* 'NULL1 ) 

OPEN  <52,  FILE-'CLIBRY1,  STATUS* ‘UNKNOWN1 ,  ACCESS*'DIRECT1 
1  FORM* 'FORMATTED1,  RECL*110,  BLANK* 1  NULL 1 ) 

OPEN  (SO,  F I LE-'RAYDAT1, STATUS* 'UNKNOWN1) 

RAY  I  NX  *  .FALSE. 

C 

C .  TOP  OF  LOOP  . 

C 

C  GET  THE  NEXT  ENTRY  FROM  THE  LIBRARY  INDEX 


C 

40  CALL  GETREC  (NSTREC,  NREC,  NSUREC,  MRFG,  ID 
INOXR  *  II 
C 

C  CHECK  FOR  END  OF  MATCHING  RECORDS 

C 

IF  (MRFG)  GOTO  SOO 
IF  (NREC.LE.O)  GOTO  40 
C 

C  READ  TIME  HISTORY  FROM  DISK  TO  MEMORY 

C 

50  NMTCH  *  NMTCH  ♦  1 
SECS  *  0. 

SEC8  *  0. 

[R  «  NSTREC 

REAO  (2,2001 ,REC*IR)  MNAME ,  MOATE,  STARTT,  ACTYPE,  ACTAIL 
IR  *  IR  ♦  1 

REAO  (2,2002, REC*IR)  SITELC,  MSEG 
IR  *  IR+1 
C 

C  FIND  OVERPRESSURE  FACTOR  AND  WEIGHT  IN  KG 

C 

CALL  OPFINO  (ACTYPE,  OPFACT,  ACWT) 

ACTYP  *  ACTYPE 

IF  (OPFACT  .EQ.  0.0  .OR.  NSUREC  .LE.  1)  GOTO  70 
C 

C  LOOK  UP  TEST  RANGE  ALTITUDE,  LATITUDE  AND  LONGITUDE 

C 

CALL  RNGALT  (SITELC,  RZMIN) 

CALL  RNGLL  (SITELC,  LAT,  LONG) 

2GRND  *  RZMIN 
C 


i 


C-  INITIALIZE  RAY  TRACING  ROUTINES 

C 

CALL  SETUP 
C 

C  READ  FLIGHT  TIME  HISTORY  INTO  ARRAY 

C 

NFP  *  NREC  -  3 
IF  (NFP  .L£.  1)  GOTO  70 
IF  (NFP  .GT.  1156)  STOP2 
C 

00  60  1*1 ,NFP 

READ  (2,2003,REC*!R)  FHR,  FMIN,  FSEC,  FMACH(I),  FX(I), 

1  FY ( I ) ,  FZ(I),  CA( I ),  VX(1),  VY(I),  VZ(I) 

IR  *  IR  +  1 

FTIME(I)  *  FHR*3600.  +  FHIN*60.  ♦  FSEC/100. 

60  CONTINUE 
C 

C  READ  FINAL  RECORD 

C 

70  IR  *  NSTREC  ♦  NREC  •  1 

READ  (2,2004,REC*IR)  ENDT,  NRECO ,  NMACH 
IF  (OPFACT  .EO.  0.0  .OR.  NSUREC  .LE.  1)  THEN 
NSU8  *  NSU8  *  1 
GOTO  310 
END  IF 
C 

C  GO  THRU  THE  FLIGHT  AT  ONE  SECONO  INTERVALS 

C 

C 

c 

IF  (NFP  .LE.  1)  GO  TO  40 
FTO  *  FT  I ME ( 1 ) 

FTN  *  FTIME(NFP) 

C 

C  PRESET  CURRENT  MACH  .GT.  1.0  AND  MACH  .GT.  CUTOFF 

C  AS  .FALSE. 

C 

LMFG  *  .FALSE. 

LMCFL1  *  .FALSE. 

C 

JO  *  2 
FT  *  FTO 

105  DO  110  J*JO,NFP 
10  *  J  •  1 

IF  (FT  .LE.  FTIME(J))  GO  TO  115 
110  CONTINUE 
C 

C  RAN  OUT  OF  DATA  POINTS,  ALL  DONE  WITH  THIS  FLIGHT 

C 

WRITE  (3,3001)  FTDELM 
WRITE  (4,4001)  FTDELM 
GOTO  300 
C 


115  JO  *  10  ♦  1 

FT  10  =  FTIME(IO) 

FTJO  *  FTIME(JO) 

C 

C  REMEMBER  MACH  STATUS  AND  LATERAL  BOOM  PROPAGATION 

C  POINTS  Of  PREVIOUS  DATA  POINT  ONE  SECOND  AGO 

C 

LMCFLO  *  LMCFL1 
C  ELXO  *  ELX1 

C  ELYO  *  ELY1 

C  ERXO  *  ERX1 

C  ERYO  «  ERY1 

XCO  »  XC 
YCO  *  YC 
C  BXO  *  SX 

C  BYO  *  BY 

HEO  *  HE 
DYCO  *  OYC 
C  DLATO  =  OLAT 

XLCEO  *  XLCE 
C 

C  TEST  FOR  5.0  SECONO  OR  GREATER  GAP,  IF  TRUE  ASSUME 

C  A/C  WENT  SUBSONIC  IN  THE  INTERIM 

C 

IF  (CFTJO-FTIO)  .LE.  5.0)  GOTO  117 
IF  (LMFG)  WRITE  (3,3001)  FTOELM 
LMFG  *  .FALSE. 

IF  (LMCFL1 )  WRITE  (4,4001)  FTDELM 
LMCFL1  *  .FALSE. 

FT  =  FTJO  ♦  0.01 
GOTO  105 
C 

C  ELSE  CALCULATE  NEXT  X-COORD,  Y-COORD,  Z-COORD,  CLIMB  ANGLE, 

C  MACH  #,  GAMMA,  HEIGHT  ABOVE  GROUND 

C 

117  CONTINUE 

XC  *  (FX(JO)  •  FX( 10) )® ( FT  •  FTJO)  /  (FTJO  •  FTIO)  ♦  FX(IO) 

YC  =  (FY(JO)  •  FY( 10) )*( FT  •  FTIO)  /  (FTJO  •  FTIO)  ♦  FY(IO) 

ZC  »  (FZ(JO)  •  FZ( 10) >*( FT  •  FTIO)  /  (FTJO  •  FTIO)  +  FZ(IO) 

XCA  *  (CA(JO)  -  CA(IO))  «  (FT  -  FTIO)  /  (FTJO  -  FTIO)  +  CA(IO) 
XMT  *  (FMACH(JO)  •  FMACH(IO))  *  (FT  •  FTIO)  /  (FTJO  •  FTIO)  * 

1  FMACH(IO) 

CALL  SOUNO(ZC,CO) 

VXC  *  (VX(JO)  •  VX( 10) )*( FT • FT1 0)  /  (FTJO  •  FTIO)  ♦  VX(IO) 

VYC  *  (VY(JO)  •  VY( 1 0) )*( FT  - FTIO)  /  (FTJO  -  FTIO)  ♦  VY(IO) 

VZC  *  (VZ(JO)  •  VZ( 1 0) )*( FT  -  FT  10)  /  (FTJO  ■  FTIO)  *  VZ(IO) 

VEL  =  (VXC**2  +  VYC**2  ♦  VZC**2)**0.5 

XM  =  VEL/CO 


GAMMA  *  XCA  *  1.74S329E-2 
HG  =  RZMIN 
HA  a  ZC 


H  a  HA  •  HG 

IF  (XMT  -  1.)  120,  23,  25 


C 

C  FOR  MACH  MO.  TELEMETERED  FROM  A/C,  XMT 
C 

C  IF  CURRENT  MACH  #  LESS  THAN  1 

C 

23  NMET  «  NMET  ♦  1 
GO  TO  120 

C 

C  IF  CURRENT  MACH  #  GREATER  THAN  1 
C 

25  NMET  *  NMET  +  1 

XMET  »  1.  /  (SIN(GAMMA  ♦  ATAN<1 ./S0RT(XMT**2- 1 . )) )) 
XMCT  «  EXP  (4.033E-6  *  AMIN1 (HA, 35300. ) ) 

IF  (XMET  .LE.  XMCT  .OR.  XMT  .LE.  XMCT)  GO  TO  120 

C 

C  IF  CURRENT  MACH  #  GREATER  THAN  CUTOFF 

C 

NCET  «  MCET  ♦  1 
C 

120  IF  (XM  •  1.)  122,123,125 
C 

C  FOR  MACH  NO.  CALCULATED  FROM  VELOCITIES. 

C 

122  IF  (LMFG)  WRITE  (3,3001)  FTDL..N 
LMFG  a  .FALSE. 

IF  (LMCFL1 )  WRITE  (4,4001)  FTDELM 
LMCFL1  *  .FALSE. 

GOTO  290 
C 

C  IF  CURRENT  MACH  #  BETWEEN  1  AND  CUTOFF 

C 

123  WRITE  (3,3001)  XC,  TC 
NME  »  NME  ♦  1 

SECS  a  SECS  ♦  FTINC 
LMFG  *  .TRUE. 

124  IF  (LMCFLl )  WRITE  (4,4001)  FTDELM 
LMCFL1  a  .FALSE. 

GOTO  290 
C 

C  IF  CURRENT  MACH  #  GREATER  THAN  1 

C 

125  XME  a  1.  t  (SINCGAMMA  ♦  ATAN(1 .  /  SQRT(XM**2  -  1.)))) 
XMC  a  EXP(4.033E-6  *  AMINKHA,  35300.)) 

LMFG  =  TRUE. 

WRITE  (3,3001)  XC,  TC 

NME  a  NME  +  1 

SECS  a  SECS  *  FTINC 

IF'  (XME  .LE.  XMC  .OR.  XM  .LE.  XMC)  GO  TO  124 


I 


i 


8 


8 


c 

C 


IF  CURRENT  MACH  #  GREATER  THAN  CUTOFF 


c 

LMCFLl  »  .TRUE. 

WRITE  (4,4001)  XC,  YC 
SECS  *  SECS  ♦  FT IRC 
XKD1C  a  2.  ♦  4.53E-6  *  HA 

IF  (HA  .GT.  35300.)  XKD1C  =  2.3929  -  6.6E-6  *  HA 
C 

130  XNO  =  0.22  +  1.6E-6  *  HA 

XKD  *  XKD1C  ♦  (1.04  -  XXD1C)  *  ((XME  •  XMC)  /  (XME  •  1.))  **  XNO 
OX  *  XKD  *  H  /  SORT (XME**2  -  1.) 

OYC  *  H  *  ( ( 1 . *XMC )  /  XM)  *  S0RT((XM**2  -  XMC*»2)  /  (XMC**2- 1 . > ) 

HE  a  H  *  COS (GAMMA)  +  OX  *  SIN(GAMMA) 

DA  »  (1.  -  6.8756E-6  *  HA)  **  5.2559 

DG  =  (1.  •  6.8756E-6  *  H  )  **  5.2559 

OP  =  (8.4E3  *  SORT (DA*DG)  •  (XM»»2  -  1.)  **  0.125)  /  HE  **  0.75 
OP  a  OP  «  OP FACT 
C 

XLPK  a  20.  *  ALOGIO(OP)  +  127.6 
XLCE  =  XLPK  ■  26.0 
XLAE  a  188.7  »  ALOG(XLPK)  -  825.6 
C 

C  UPDATE  RMS  VALUES 

C 

RMSHE  a  RMSHE  ♦  HE*HE 

RMSMN  *  RMSMN  +  XM»XM 

RMSCMN  a  RMSCMN  ♦  XMC*XMC 

RMSEMN  a  RMSEMN  ♦  XME*XM£ 

C 

C  UPDATE  STATISTICAL  MATRICES 

C 

IX  =  I F I X ( (XC  •  RXMIN)  /  RXCL)  ♦  2 
IX  a  MAXO(MINO(IX,  NX),  1) 

IY  a  I FIX( (YC  •  RYMIN)  /  RYCL)  ♦  2 
IY  a  MAXO(MINO( I Y ,  NY),  1) 

IZ  =  I FIXCCZC  •  RZMIN)  /  RZCL)  ♦  2 
IZ  a  MAXO(MINO(IZ,  NZ),  1) 

I  HE  *  I  FIX ((HE  •  RHEMIN)  /  RHCL)  ♦  2 
I  HE  =  MAX0(MI N0< I  HE ,NH) ,  1) 

IM  a  I F IX( (XM  -  RMMIN)  /  RMCL )  ♦  2 
IM  a  MAXO(MINO(IM,  NM),  1) 

IMC  =  I F IX( (XMC  •  RMMIN)  /  RMCL)  ♦  2 
IMC  a  MAX0(MI N0( IMC,  NM),  1) 

IME  a  [ F I X ( ( XME  •  RMMIN)  /  RMCL)  *  2 
IME  a  MAX0(M!N0( IME,  NM),  1) 

10P  =  IFIXKOP  •  ROMIN)  /  ROCL)  ♦  2 
IOP  =  MAX0(HIN0( IOP ,  NO),  1) 

I LPK  a  IFIX((XLPK  ■  RLPMIN)  /  RLCL)  *  2 
I LPK  a  MAX0(MI N0( I LPK ,  NL),  1) 

ILCE  =  I FIX( (XLCE  •  RLCMIN)  /  RLCL)  *  2 
ILCE  =  MAX0(MI N0( ILCE,  NL),  1) 

I  LAE  a  I FIX( (XLAE  ■  RLAMIN)  /  RLCL)  ♦  2 
I  LAE  a  MAXQ(MI N0( I  LAE ,  NL),  1) 

C 

MXY (IX, I Y)  =  MXY ( IX , I Y)  ♦  1 


MX(1X)  *  MX(1X)  +  1 
MY(1Y)  *  MY(1Y)  ♦  1 
MZ(1Z)  *  MZ(iZ)  ♦  1 
NHE(IHE)  *  NHE(IHE)  ♦  1 
MM(IH)  *  MW(IM)  *  1 
MMC(IMC)  *  MNC(IMC)  +  1 
MME(IME)  =  MME(IME)  ♦  1 
HOP(IOP)  *  HOP(IOP)  *  1 
MLPK(ILPK)  =  MLPK(lLPtC)  ♦  1 
MLCE(ILCE)  *  MLCE(ILCE)  ♦  1 
MLAE < I  LAE )  *  MLAE(ILAE)  +  1 
MCE  «  MCE  ♦  1 
C 
C 

290  FT  *  FT  ♦  FTIMC 
GOTO  105 

300  IF  (SEC8  .GT.  0.0)  THEN 
NBOOM  •  MBOCM  ♦  1 
END  IF 

IF  (SECS  .GT.  0.0)  THEN 
NSUP  *  NSUP  ♦  1 
ENOIF 
C 

310  IF  (LINCNT  .G£.  0)  THEM 
LIMCNT  *  -50 
WRITE  (6,6001)  TITLE 
ENOIF 
C 

LIMCNT  *  LIMCNT  ♦  1 

WRITE  (6,6002)  HUTCH,  MNAME,  NDATE,  SITELC, 

1  STARTT (1:2),  STARTT(3:4),  STARTT(5:6),  STARTT(7 :B) , 

2  ENOT (1:2),  ENOT(3:4),  ENDT(5:6),  ENDT(7:8), 

3  ACTYPE,  ACTAIL,  SECS,  SECB 
TSECS  =  TSECS  ♦  SECS 

TSECB  =  TSECB  +  SECB 
C 

c 

C 

C . 

C-  CALL  RAY  TRACING  ROUTINES 
C 

7878  CONTINUE 

IF  ( .NOT .RAYTRC)  CALL  RTRACE 

C . 

GOTO  40 
C 
C 

c 

500  CONTINUE 
C 

C  REPORT  TOTALS 

C 

WRITE  (6,6003)  NSUP,  TSECS,  TSECB,  NBCOM 
WRITE  (6,6004)  NME,  NCE,  NMET,  NCET 


c 

c 

IF  ((.MOT.  STATFG)  .OR.  (SECB  .EQ.  0.0))  OOTO  600 
C 

C  PRINT  STATISTICAL  SUMMARY 

C 

FNCE  *  FLOAT(NCE) 

RMSHE  ■  SORT(RMSHE/FNCE) 

RMSMN  »  SORT (RMSMN/FNCE) 

RMSCMN  *  SORT (RMSCMN /FNCE) 

RMSEMN  >  SORT (RMSEMN/FNCE) 

C 

WRITE  (6,6000) 

WRITE  (6,6012)  TITLE 
WRITE  (6,6010)  IDX,  RXMIN,  RXCL,  MX 
WRITE  (6,6010)  IOY,  RYM1N ,  RYCL,  MY 
WRITE  (6,6010)  I0Z,  RZMIN,  RZCL,  MZ 
WRITE  (6,6014)  I DHE ,  RHEMIN,  RHCL,  RMSHE,  MHE 
WRITE  (6,6014)  I0M,  RMMIN,  RMCL,  RMSMN,  MM 
WRITE  (6,6014)  IDMC,  RMMIN,  RMCL,  RMSCMN,  MMC 
WRITE  (6,6014)  IDME,  RMMIN,  RMCL,  RMSEMN,  MME 
WRITE  (6,6010)  IOOP,  ROMIN,  ROCL,  MOP 
WRITE  (6,6010)  IDLPK,  RLPMIN,  RLCL,  MLPK 
WRITE  (6,6010)  IDLCE,  RLCMIN,  RLCL,  MLCE 
WRITE  (6,6010)  IOlAE,  RLAMIN,  RLCL,  MLAE 
WRITE  (6,6011)  NME,  NCE 
C 

DO  831  IJ  «  1,52 
DO  832  IK  *  1 ,NY 

I  F  (MXY(IJ,IK).EQ.O)  THEN 
AMXY ( 1 J , IK)  =  '  .  ' 

ELSE 

WRITE(CSUF, '(14)')  MXY ( I J , I K ) 

READ(C8UF, 1 (A4) ' )  AMXY(IJ,1K) 

END  IF 

832  CONTINUE 
831  CONTINUE 

WRITE  (6,6000) 

WRITE  (6,6010)  IDX,  RXMIN,  RXCL 

WRITE  (6,6010)  IDY,  RYMIN,  RYCL 

DO  510  JY*1,NY 
IY  *  NY  -  JY  ♦  1 

510  WRITE  (6,6021)  IY,  (MXY(IX.IY),  !X=1,30) 

WRITE  (6,6000) 

WRITE  (6,6010)  IOX,  RXMIN,  RXCL 

WRITE  (6,6010)  IDY,  RYMIN,  RYCL 

DO  520  JY>1,NY 
IY  *  NY  -  JY  ♦  1 

520  WRITE  (6,6021)  IY,  (MXY(IX,IY),  IX=31,NX) 

C 

C  SET  FLAGS  FOR  VARIOUS  GPCP  OUTPUTS 

C 

600  CONTINUE 

GPCPMH  =  MACHFG 


J 


GPCPBM  *  SOOHFG 
GPCPCN  *  CONTFG 

GPCPFL  «  GPCPMH  .OR.  GPCPBM  .OR.  GPCPCN 
C 

CLOSE (51) 

CLOSE (52) 

CALL  STORECC TITLE .GPCPFL,  GPCPMH,  GPCPBM) 

WRITE  (6,6000) 

STOP 

C 

C  FORMAT  STATEMENTS 
C 

2001  FORMAT  (A16,  A8,  A8,  A6,  A8) 

2002  FORMAT  (2X,  A10,  2X,  12) 

2003  FORMAT  (2X,  2F2.0,  F4.Q,  F6.0,  3F8.0,  F6.0,  3F6.0) 

2223  FORMAT  (2X, F12.2,2X,  2F3.0,  F5.0,  F8.2,  3F10.2,  F8.2,  3F8.2) 

2004  FORMAT  (A8,  218) 

C 

3001  FORMAT  (2F10.0) 

C 

4001  FORMAT  (2F10.0) 

6000  FORMAT  (1H1) 

6001  FORMAT  ('I'  //  1  10X,  ‘TITLE:  A70  // 

1  '  58X,  'STARTING  FINISHING'  / 


2 

1 

',  35X,  'MISSION 

SITE 

TIME 

TIME 

3 

A/C 

A/C  SUPERSONIC 

BOOM'  / 

4 

1 

',  12X,  'NO  MISSION  NAME 

DATE 

LOCATION 

HR 

5 

MN  SECS 

HR  MN  SECS  TYPE 

TAIL  NO 

TIME  (SEC) 

TIME  (SEC) 

'/ 

6  '  10X,  .  . 

. . 

8') 

6002  FORMAT  ('  ',  10X,  15,  2X,  A16,  2X,  A8,  2X,  A10,  2C2X,  A2, 

1  A2,  A2,  A2),  2X,  A6,  2X,  A8,  2X,  F7.1,  5X, 

2  F7.1) 

6003  FORMAT  ('O',  101X,  . .  / 

1  '  ',  17X,  'NUMBER  OF  SUPERSONIC  SORT  I ES( FLIGHTS) : ' ,  15, 

2  33X,  'TOTAL:*,  F9.1,  3X,  F9.1  / 

3  '  ',  17X,  'NUMBER  OF  BOOM  PROOUCING  SORTIES(FLIGHTS) : ‘ , 15) 

6004  FORMAT  ('O',  17X,  'USING  MACH  NO  CALCULATED  FROM  GROUND' 

1  ,  'VELOCITIES',/ 

2  ,'  ' ,21X, 'TOTAL  SUPERSONIC  TIME  =',110,'  SECONDS',/ 

3  ,'  \21X, 'TOTAL  BOOM  PROOUCING  TIME  =',110,'  SECONDS',/ 

4  ,'  ' , 17X, 'USING  TELEMETERED  MACH  NO  CALCULATED  FROM  AIRSPEED',/ 

5  ,'  ',21X, 'TOTAL  SUPERSONIC  TIME  *',110,'  SECONDS',/ 

3  ,'  ' ,21X, 'TOTAL  BOOM  PROOUCING  TIME  *',110,'  SECONDS',/) 

6006  FORMAT  (1H0,  '  NON -SUPER SONIC  A/C') 

6010  FORMAT  (1H0,  10X,  A20,  ■  LOWER  BOUNO  CELL  2  =’,  F10.1, 

1  1  CELL  SIZE  =*,  F9.3  /  (1H  ,  10X,  2015)) 

6011  FORMAT  (1H0,  10X,  'TIME  GREATER  THAN  MACH  1.0  (SEC)  =',  16, 

1  '  TIME  GREATER  THAN  CUTOFF  MACH  NO  (SEC)  =',  16) 

6012  FORMAT  ( 1 H  ,  10X,  'TITLE:  ',  A) 

6014  FORMAT  (1H0,  10X,  A20,  '  LOWER  BOUND  CELL  2  =',  F10.1, 

1  '  CELL  SIZE  =',  F9.3,  '  RMS  =',  F9.3  / 


2  (1H  ,  10X,  2015)) 

6021  FORMAT  <1H  ,  2X,  IS,  2X,  3014) 

6901  FORMAT  (1H0,  13F10.0  /  1H  ,  4F10.0,  3F10.5) 

6902  FORMAT  ('O',  'XPLY/YPLY',  8E15.7) 

6903  FORMAT  ('O',  'XTR/YTR' ,  6E15.7) 

6904  FORMAT  (•  ',  'X8MIN/YBMIN' ,  2E15.7, 

1  '  XSMAX/YBMAX ' ,  2E15.7) 

6905  FORMAT  ('  ',  'V12V1G/V1GV13/V23V2G/V2GV21 ' ,  4E15.7) 

6906  FORMAT  ('  ',  'ANG21G/ANGG13' ,  2E15.7) 

6907  FORMAT  ('  ',  ' ANG32G/AANGG21 ' ,  2E15.7) 

6908  FORMAT  ('  ',  ' XBM/XBB ' ,  2E1S.7) 

6909  FORMAT  (•  ',  'GPX/GPYX/GPY' ,  3E15.7) 

6910  FORMAT  ('  ',  'OLATO/OYCO/HEO/XLCEO/XLCEI ' ,  5E15.7  / 

1  '  ',  'DLAT/DYC/HE/XLCE/XLC62' ,  5E15.7  / 

2  '  ',  ' ALPHA/BETA/XLCEGR' ,  3E15.7) 

6920  FORMAT  ('V,  5X,  2515) 

6921  FORMAT  ('O',  14,  IX,  25F5.1) 

C 

C 

C  DATA  STATEMENTS 

C 

DATA  IOX,  IDY,  IDZ  /  'X-COORD',  'Y-COORD',  '2-COORD'  / 

DATA  1DHE,  I DM  /  'EFFECTIVE  HEIGHT',  'MACH  NUMBER'  / 

DATA  IDMC,  IDME  /  'CUTOFF  MACH  NO.*,  'EFFECTIVE  MACH  NO.'  / 
DATA  IDOP,  1DLPK  /  'OVERPRESSURE  (PSD*,  'PEAK  LEVEL'  / 

DATA  I0LCE,  IDLAE  /  'C-LEVEL',  'A-LEVEL'  / 

C 

DATA  NX,  NY,  NZ,  NH,  NM,  NL,  NO  /  52,  52,  52,  52,  59,  79,  59  / 
DATA  RXMIN,  RXCL  /  -132000.,  5280.  / 

DATA  RYMIN,  RYCL  /  -132000.,  5280.  / 

DATA  RZMIN,  RZCL  /  0.,  1000.  / 

DATA  RHEMIN,  RHCL  /  0.,  1000.  / 

DATA  RMMIN,  RMCL  /  1.00,  0.02  / 

DATA  ROMIN ,  ROCL  /  0.0,  0.25  / 

DATA  RLPMIN,  RLCMIN,  RLAMIN,  RLCL  /  115.0,  90.0,  80.0,  0.5  / 

C 

ENO 


c 


SUBROUTINE  OPFINO  (ACTYPE, OPFACT.ACWT) 


C 

C  ROUTINE  TO  LOOK  UP  A/C  OVERPRESSURE  FACTOR 

C 

CHARACTER*6  ACTYPE,  ACTABLC30) 

C 

REAL  OP FACT ,  OPTABL(30),  ACUT,  WTABL(30) 

C 

C 


C 


c 

c 


c 


c 


OP FACT  *  0.0 
OO  20  1=1,30 

IF  (ACTA8UI)  .£0.  1  ')  RETURN 
IF  (ACTYPE  .NE.  ACTA8KI ))  GOTO  20 
OPFACT  =  OPTABL(I) 

ACUT  =  WTABL(I) 

RETURN 
20  CONTINUE 
RETURN 


DATA 

ACTABL 

/ 

'A-4',  'A-6‘,  ‘  A-7' ,  'A- 10' ,  1 

AV-8' 

1 

1 F-5 1 ,  'F-81 ,  1 F-14 1 ,  ‘F-15 1 , 

1 F- 16 

2 

1 F - 1 04 1 ,  ‘F-106’,  'F-111 1 ,  ‘OV 

-10\ 

DATA 

OPTABL 

/ 

1.0,  1.0,  1.0,  1.0,  1.0,  0.93, 

1 

0.76,  0.86,  1.00,  1.00,  0.80, 

0.91, 

2 

0.89,  1.08,  1.11,  1.0,  14*1.0 

/ 

DATA 

UTABL 

/ 

1.0,  1.0,  1.0,  1.0,  1.0,  1.0, 

1 

1.0,  1.0,  1.0,  1.0,  16040.0,  1 

•0, 

2 

16040.0,  1.0,  1.0,  1.0,  14*1.0 

/ 

Jl 


END 


c 

c 

SUBROUTINE  RNGALT  (SITLC,  RZMIN) 

C 

DIMENSION  SITEC20),  SITALK20) 

C 

CHARACTER*10  SITE 
CHARACTER*!*)  SITLC 

C 

c 

DO  20  1*1,20 

RZMIN  *  SITAIT(I) 

IF  (SITE! I )  .EQ.  •  ')  RETURN 
IF  (SITLC  .EQ.  SITE!!))  RETURN 
20  CONTINUE 
C 

RZMIN  *  0. 

RETURN 

C 

c 

DATA  S I TE/' OCEANA ' ,  'TYNDALL',  'LUKE',  'HOLLOMAN',  'NELLIS' 
1  , ' YUMA ','LLLL','LB8B‘,'B8BB','TTTT',  10*'  1  / 

DATA  SITALT  /  0. , 0. ,750. ,4500. ,5500. , 800. , 1000. 0 , 10000. 0 , 

1  3800.0,  0.0,  10*0.  / 

END 


SUBROUTINE  RNGLL  (SITLC,  LAT,  LONG) 

DIMENSION  SITE(20),  SITLAK20),  SITLONC20) 

CHARACTER* 10  SITE,  S1TLAT ,  SITLON,  LAT,  LONG 
CHARACTER*(«)  SITLC 


00  20  1*1,20 

LAT  *  SITLAT(I) 

LONG  *  SITLON(I) 

IF  (SITE(l)  .EQ.  1  ')  RETURN 
IF  (SITLC  .EQ.  SITE(D)  RETURN 
20  CONTINUE 

LAT  =  '  1 
LONG  *  '  1 
RETURN 


DATA  SITE/' OCEANA',  'TYNDALL',  'LUKE',  'HOLLOMAN',  'NELLIS' 

1  , 'YUMA', 14*'  •  / 

DATA  SITLAT/'  36  00.0  N','  29  32.0  N','  32  23.48N','  33  48.0  N 

1  ,'36  50.29N','  32  29.24N',14*'  UNKNOWN  '  / 

DATA  SITLON/'  75  10.0  U' , '  84  37.0  U' , ' 113  15.0  U','106  25.0  U 

1  ,'115  25. 36W',  '113  52. 56U\  14*'  UNKNOWN  •/ 

END 


REAL  FUNCTION  DISADJ  (DLAT.DYC,  HE) 

C 

C 

C  FUNCTION  TO  CALCULATE  DISTANCE  ADJUSTMENT  IN  DB 

C  FROM  THE  EFFECTIVE  HEIGHT  (HE)  TO  A  LATERAL 

C  SIDELINE  POINT  AT  A  DISTANCE  (DLAT)  FROM 

C  THE  FLIGHT  TRACK 

C 
C 

OISRAT  *  SORT (DLAT**2  ♦  HE**2)  /  DYC 
HEDYC  *  15.  *  ALCG10CHE/DYC) 

C 

IF  (DISRAT  .LT.  0.8)  THEN 
OISAOJ  *  -15.  *  ALOGIO(DISRAT)  ♦  HEDYC 
RETURN 
C 

ELSEIF  (DISRAT  .LT.  1.0)  THEN 
DISADJ  =  -118.1885  *  ALOGIO(OISRAT)  -  10.  ♦  HEDYC 
RETURN 
C 

ELSE 

DISADJ  =»  -25.  *  ALOGIO(OISRAT)  -  10.  ♦  HEDYC 
RETURN 
END  IF 
C 

END 


c 

SUBROUTINE  GETAIF  (X,Y,XG,YG, ALPHA, BETA) 

C 

C  SUBROUTINE  TO  CALCULATE  ALPHA  AND  BETA  FACTORS 

C  FOR  EXPOSURE  LEVEL  INTERPOLATION 

C 
C 

DIMENSION  ALF(2),  X<4),  Y(4) 

LOGICAL  FG1,  FG2 
C 
C 

P  *  Y(3)  -  Y(4) 

0  =  X(2)  -  X<1)  -  X(3)  ♦  X(4) 

R  =  X(3)  -  X(4) 

S  a  Y(2)  •  Y(1)  -  Y(3)  ♦  Y(4) 

T  =  X(1)  •  X<4) 

U  =  Y(4)  -  YG 
V  *  Y<1)  •  Y(4) 

U  »  X<4)  •  XG 
C 

A  *  P*Q  •  R*S 
B  a  P*T  *  Q*U  •  R*V  -  S*U 
C  =  U*T  •  W*V 
C 

IF  (AB?(A)  .LE.  1.E-6)  THEN 
ALF(  1 )  =  -C/B 
ALF(2)  =  0.0 
GOTO  30 
C 

ELSE 

RAD  *  8**2  •  4.0*A*C 
C  IF  (RAO  .LT.  0.0)  ST0P91 

IF  (RAO  .LT.  0.0)  RAO  *  ABS(RAO) 

RAO  =  SORT (RAD) 

ALF(1 )  *  ( -B  +  RAD)  /  (2.*A) 

ALF(2)  s  ( -B  ■  RAD)  /  (2.*A) 

GOTO  30 
C 

END  I F 
C 

30  FG1  *  (ALF(1 )  .GE.  0.0  .ANO.  ALF(1)  .LE.  1.0) 

FG2  =  (ALF(2)  .GE.  0.0  .AND.  ALF(2)  .LE.  1.0) 

C 

IF  (FG1  .AND.  FG2)  GOTO  40 
IF  ( FG1 )  ALPHA  =  ALF( 1 ) 

IF  (FG2)  ALPHA  =  ALF(2) 

GOTO  60 

40  00  50  1*1,2 

YA  *  Y { 4 )  ♦  ALF(I)  *  (Y(3)  -  Y(4)) 

XA  *  X(4)  +  ALF(I)  *  (X(3)  -  X(4 ) ) 


I 


J 


ft 


C 


Y8  *  tel)  *  alf<d  *  crc2>  •  rnj) 

X8  *  X<1)  ♦  ALF(I)  *  (X(2)  -  X(1)) 

IF  (YB  .EQ.  YA)  THEN 

IF  (YG  .NE.  YA)  GOTO  50 
ELSE 

Z  *  (YG-YA)/<Y8-YA) 

IF  (2  .LT.  0.0  .OR.  Z  .GT.  1.0)  GOTO  50 
END  IF 
C 

IF  <XB  .EQ.  XA)  THEN 

IF  <XG  .NE.  XA)  GOTO  50 
ELSE 

Z  <  (XG-XA)/(XB-XA) 

IF  (Z  .LT.  0.0  .OR.  Z  .GT.  1.0)  GOTO  50 
END  IF 
C 

ALPHA  *  ALF(l) 

GOTO  60 
50  CONTINUE 
STOP92 
C 

60  YBMYA  «  ALPHA  «  S  ♦  V 
XBMXA  «  ALPHA  *  Q  *  T 
IF  (ABS(YBMYA)  .GT.  ABS(XBMXA))  THEN 
BETA  *  (YG  -  ALPHA*?  •  Y<4))  /  YBMYA 
GOTO  70 
ELSE 

BETA  *  (XG  -  ALPHA'R  •  X(4))  /  XBMXA 
GOTO  70 
ENOIF 
C 

70  ALF1  *  ALF(I) 

ALF2  *  ALF(2) 

RETURN 

C 

END 


c 

c 

c 


SUBROUTINE  MAKETR  (X,  Y,  XT,  YT) 


C 

C  SUBROUTINE  TO  MAKE  TWO  TRIANGLES  OUT  OF  A 

C  FOUR- SIDED  POLYGON 

C 
C 

DIMENSION  X(4) ,  Y(4),  XT(3,2),  YT<3,2) 

C 

XI  *  X<1) 

X2  *  X(2) 

X3  a  X(3) 

X4  *  X(4) 

Y1  «  Y(1 ) 

Y2  *  Y(2) 

Y3  a  Y(3) 

Y4  a  Y<4) 

C 

C  ADJUST  POINTS  SO  SLOPES  CAN'T  BE  INFINITE 

C 

IF  (ABS(X2  •  XI)  .LT.  0.01)  X2  »  X2  ♦  0.1 

IF  (ABS(X3  -  X4)  .LT.  0.01)  X3  *  X3  ♦  0.1 

IF  (A8S(X2  •  X3)  .LT.  0.01)  X3  *  X3  ♦  0.1 

C 

FM1  a  <Y2  -  YD  /  (X2  ■  X1> 

FBI  a  Y1  -  FM1*X1 

FM2  a  (Y3  •  Y4)  /  <X3  -  X4 ) 

FB2  a  Y3  -  FM2*X3 
C 

IF  ( FM1  .EQ.  FM2)  GOTO  40 
XC  *  (FBI  -  FB2)  /  (FM2  •  FM1 ) 

YC  =  (FM2*FB1  -  FM1*F82)  /  (FM2  •  FM1 ) 

TEMPI  a  (XC  •  XI)  /  (X2  -  XI) 

C 

IF  (TEMPI  .GE.  0.0  .AND.  TEMPI  .LE.  1.0)  THEN 
XT ( 1 , 1 )  a  XI 
YT< 1,1)  =  Yl 
XT(2,1)  a  XC 
YT(2,1)  a  rc 
XT(3,1)  a  X4 
YT(3,1)  =  Y4 
XT( 1 ,2)  a  X3 
YT( 1 ,2)  a  Y3 
XT(2,2)  a  XC 
YT(2,2)  =  YC 
XT (3,2)  a  X2 
YT(3,2)  =  Y2 
RETURN 
END  IF 
C 


V12V14  a  (X2-X1)*(Y4-Y1)  -  (Y2-Y1)*(X4-X1) 


V23V21  *  <x3-x2)»<yi-y2)  •  (r3-r2)»(xi-x2) 

V34V32  «  (X4*X3)*(Y2’Y3)  •  (Y4- Y3)*(X2-X3) 

V41V43  *  <X1-X4)«(Y3-Y4)  •  (Yl -Y4)«(X3-X4) 

C 

V12V14  »  SIGNC1 . , V12V14) 

V23V21  *  SIGNO  . ,  V23V21 ) 

V34V32  »  S I GN  < 1 . , V34V32 ) 

V41V43  *  SIGN<1.,V41V43) 

C 

VSUH  *  V12V14  ♦  V23V21  ♦  V34V32  +  V41V43 
IF  (ABS(VSUM)  .£0.  4.)  GOTO  40 
C 

IF  (VSUM  .GT.  0.)  GOTO  30 
V12V14  a  -V12V14 

V23V21  =  -V23V21 

V34V32  *  -V34V32 

V41V43  =  -V41V43 

C 

30  IF  (V12V14  .EQ.  -1.  .OR.  V34V32  .EQ.  -1.)  GOTO  60 

IF  (V23V21  .EQ.  -1.  .OR.  V41V43  .EQ.  -1.)  GOTO  SO 

ST0P93 
C 

40  013  *  ((X3-X1 )**2  ♦  (Y3-Y1 )**2> 

024  »  (<X2-X4)««2  ♦  (Y2-Y4)**2) 

C 

IF  <024  .GT.  013)  GOTO  60 

50  XT<1,1)  *  XI 

YTC1.1)  a  Yl 
XT<2, 1)  *  X2 
YT(2,1)  *  Y2 
XT<3, 1 )  a  X4 
YT(3,1)  =  Y4 
XT<1,2)  a  X2 
YT<1,2)  a  Y2 
XT (2, 2)  a  x3 
YT(2,2)  a  r 3 
XTC3.2)  *  X4 
YT<3,2)  a  Y4 
RETURN 
C 

60  XT(1,1)  a  XI 

YT ( 1 , 1 )  a  Yl 
XT  <2,15  *  X2 
YT(2, 1 )  a  Y2 
XT(3 , 1  )  a  X3 
YT(3,1)  a  Y3 
XT  C 1 ,20  a  XI 
YT(1,2>  a  Yl 
XT (2,2)  a  X3 
YT(2,2)  a  Y3 
XT(3,2)  a  X4 
YT(3,2)  a  Y4 
RETURN 
C 


SLOCK  DATA  DICK 


C 

COMMON  /GRID/  GRDXO,  XGS,  GRDXMX,  GRDYQ,  YGS,  GRDYMX, 

1  UMAXO,  LIMAYO,  LIMBXO,  LIMBYO, 

2  LIMAX1 ,  LIMAY1 ,  LIKBX1,  LIMBY1 
C 

DATA  GRDXO,  XGS,  GRDXMX  /  -126250.,  2500.,  126250.  / 
DATA  GRDYO,  YGS,  GRDYMX  /  -126250.,  2500.,  126250.  / 
END 


MOOULE  NAME :  LEXPACK 
MOOULE  TYPE:  PACKAGE 

OVERVIEW: 

THIS  PACKAGE  IS  USED  TO  PERFORM  THE  LEXICAL  ANALYSIS  NECESSA 
FOR  PARSING.  THE  MAIN  PURPOSE  FOR  COMBINING  THESE  PROCEDURES  IN 
THIS  PACKAGE  IS  TO  REDUCE  THE  SCOPE  OF  DATA  COMMUNICATION  TO  THE 
SUBROUTINES  CONTAINED  IN  THE  PACKAGE. 

INTERFACE: 

GETOKN  (  PI,  P2,  P3  ) 

PI  ::=>  [CHARACTER  *(*)]  STRING  COMPOSING  THE  TOKEN 
P2  ::=  [INTEGER]  LENGTH  OF  THE  CHARACTER  STRING 
P3  [INTEGER]  VALUE  OF  THE  TOKEN 

INTERNAL  SUBROUTINES  &  FUNCTIONS: 

GETLJNO  ;  READS  ONE  LINE  FROM  SOURCE  FILE 
GETCHRO  ;  RETURNS  THE  CURRENT  INPUT  CHARACTER  FROM  BUFFER 
ADOCHRO  ;  ADOS  CURRENT  INPUT  CHARACTER  TO  THE  TOKEN  STRING 
FILEDTO  ;  NON -EXECUTABLE-  INITIALIZES  FILE  UNIT  NUMBERS 

PROGRAMMER:  BRUCE  8.  LACEY 
DATE  :  IO-OCT-85 

REVISIONS  : 

SHARED  DATA: 

BLOCK  DATA  FILEDT 

COMMON  /IOCOM/  INFILE,  LISTFL 
INTEGER  INFILE,  LISTFL 
DATA  INFILE  III ,  LISTFL/6/ 

END 


MOCULE  NAME:  LEXPACK\GETL1N 
MOOULE  TYPE:  SUBROUTINE 

OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  FILL  THE  INPUT  BUFFER  WITH  ONE  LI 
OF  SOURCE  CODE  FROH  'INFILE'.  THE  LINE  OF  CCOE  IS  THEN  ECHOED  TO 
THE  OUTPUT  FILE-  'LISTFL ' .  WHEN  THE  END  OF  FILE  IS  REACHED,  THE 
FLAG,  'ENDFLG'  IS  SET  TO  TRUE. 

INVOCATION: 

[call:  getlin  <  pi,  p2,  p3  > 

PI  ::=  [CHARACTER  *(*)]  STRING  CONTAINING  A  LINE  OF  SOU 
P 2  ::=  [INTEGER]  POINTER  TO  THE  CURRENT  POSITION  IN  PI 
P3  ::*  [LOGICAL]  FLAG  SIGNALING  THE  END  OF  FILE  ON  'INF 

VARIABLE  DICTIONARY: 


BUFFER 

;  pi 

BUFPOS 

;  P2 

ENDFLG 

;  P3 

INFILE 

;  INPUT 

FILE  CONTAINING  SOURCE  CODE  FOR 

PARSING 

LISTFL 

;  OUTPUT 

FILE  FOR  ECHOING  ' INFILE '  WITH 

ERRORS 

CALLER  MODULES: 

[FUNCTION]  LEXPACKNGETCHRO 
CALLED  MODULES: 


. . . NONE . . . 


PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  1 0 • OCT  -  85 

REVISIONS  : 


SUBROUTINE  GETLIN  <  8UFFER ,  BUFPOS,  ENDFLG  ) 

COMMON  / I OCCM/  INFILE,  LISTFL 

CHARACTER^*)  BUFFER 
LOGICAL  ENDFLG 

INTEGER  BUFPOS, I NF I Lc , L I STFL , L I NENM 

SAVE  L I NENM 


DATA  LINENM  /O/ 


C  IF  FIRST  LINE  THEN  WRITE  THE  HEADER  CARD. 

IF  !LIN£NM.EO.O)  THEN 
WRITECLISTFL.OI) 

01  FORMAT ( 1 1 1 , 1  SOURCE  LISTING:1//) 

END  IF 

C  GET  A  LINE  OF  COOE  FROM  INFILE 

READ!UNIT*INF1LE,FMT»' <A)‘ ,ERR=10,END*20)BUFFER 
C  NOW  ECHO  THE  INPUT  LINE  TO  THE  LISTING  FILE 

LINENM  *  LINENM  ♦  1 

WRITE!UNIT*LISTFL,FMT*05)  LINENM,  BUFFER 
05  FORMAT  ! IX,  13, 1 :  \A) 

BUFPOS  *  1 

C  IF  EVERYTHING  WENT  OK  THEN  RETURN 

RETURN 

C  **- EXCEPT  I ONS-** 

C  RAISE  1/0  ERROR 

10  WRITE!*, FMT=15 ) 

15  FORMAT!' I/O  ERROR  WHILE  READING  SOURCE  FILE...1) 

STOP 

C  SET  END  OF  FILE  FLAG 

20  ENOFLG  »  .TRUE. 

RETURN 

END 


MOOULE  NAME:  LEXPACKSGETCHR 

MOOULE  TYPE:  CHARACTER  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  RETURN  THE  CURRENT  INPUT 
CHARACTER  FROM  THE  INPUT  BUFFER,  UPOATING  THE  POINTER  "SUPPOS" 
ACCORDINGLY. 

INVOCATION: 

[X  *  ]  GETCHR<  PI,  P2  ) 

PI  ::*  [INTEGER!  POINTER  TO  THE  CHURRENT  POISTION  IN  PI 
P2  ::•=  [LOGICAL]  FLAG  SIGNALING  END  OF  FILE  ON  1 INF1LE' 

VARIABLE  DICTIONARY: 

BUFFER  ;  STRING*8Q  CONTAINING  CURRENT  LINE  OF  SOURCE 
BUFPOS  ;  PI 
ENDFLG  ;  P2 

INFILE  ;  INPUT  FILE  CONTAINING  SOURCE  CODE  TO  BE  PARSED 
LISTFL  ,*  OUTPUT  FILE  FOR  ECHOING  SOURCE  COOE  AND  ERRORS 

CALLER  MOOULES: 

[SUBROUTINE]  LEXPACKXGETOtCNO 

CALLED  MOOULES: 

[SUBROUTINE]  LEXPACXXGETL I  NO 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  IO-OCT-85 
REVISIONS  : 

CHARACTER*]  FUNCTION  GETCHR  (  BUFPOS,  ENDFLG  ) 

CHARACTER*80  BUFFER 
LOGICAL  ENOFLG 

INTEGER  BUFPOS,  INFILE,  LISTFL 

SAVE  BUFFER 

IF  (BUFPOS. GE.LEN(BUFFER))  THEN 
FILL  THE  BUFFER  UP 
CALL  GETLINCBUFFER, BUFPOS, ENDFLG) 

ENO  IF 

NOW  PULL  A  CHARACTER  FROM  THE  BUFFER 


GETCHR  *  SUFFER  <  8UFP0S  :  BUFPOS  ) 
8UFPOS  =  BUFPOS  ♦  1 
RETURN 
END 


MODULE  NAME:  L£XPACK\ADOCHR 
MOOULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  CONCATENATE  THE  GIVEN  CHARACTER 
WITH  THE  TOKEN  STRING  BEING  BUILT.  THE  LENGTH  OF  THE  STRING  STOR 
IN  'TKNLEN'  IS  ALSO  INCREMENTED  BY  ONE  REPRESENTING  THE  CURRENT 
LENGTH  OF  THE  TOKEN  STRING. 

INVOCATION: 

[CALL]  AODCHR  <  PI,  P2,  P3  ) 

PI  ::=  [CHARACTERS]  TO  BE  CONCATENATED  TO  P2 
P2  ::*  (CHARACTERS*)]  TOKEN  STRING 
P3  [INTEGER]  LENGTH  OF  P2 

VARIABLE  DICTIONARY: 

CC  ;  PI 
TKNLEN  ;  P3 
TKNSTR  ;  P2 

CALLER  MODULES: 

[SUBROUTINE]  LEXPACK\GETOKN() 

CALLED  MOOULES: 

[INTRINSIC  FUNCTION]  LEN( ) 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  IO-OCT-85 
REVISIONS  : 

SUBROUTINE  AODCHR  <CC,  TKNSTR,  TKNLEN  ) 

INTEGER  TKNLEN 
CHARACTERS  CC 
CHARACTERS*)  TKNSTR 

TKNLEN  *  TKNLEN  ♦  1 
I F( TKNLEN . LE . LEN( TKNSTR ) )  THEN 
TKNSTR (TKNLEN : TKNLEN )  =  CC 
END  IF 

RETURN 

END 


MODULE  NAME :  L£XPACK\G£TOKN 
MOOULS  TYPE:  SUBROUTINE 


OVERVIEW: 


THIS  SUBROUTINE  WILL  LEXICALLY  ANALYZE  AN  INPUT  STREAM  OF 
CHARACTERS,  RETURNING  THE  STRING  COMPOSING  THE  TOKEN,  THE  LENGTH 
OP  THE  STRING,  ANO  A  TOKEN  VALUE.  THE  TOKEN  VALUE  WILL  CORRESPON 
TO  THE  FOLLOWING: 


«  1 
r 

32 

1 

'/• 

== 

2 

1  .  f 

== 

3 

l  i 

== 

4 

E.O.F. 

22 

5 

LEX.  ERROR 

22 

6 

IDENTIFIER 

=  = 

7 

INTEGER 

=  = 

8 

REAL 

=2 

9 

1 ACWTN 1 

22 

10 

■AIRCRAFT' 

23 

11 

■ALL' 

33 

12 

■BOOMTRK' 

33 

13 

•CLDN' 

23 

14 

'CONTOUR' 

22 

15 

'CSEL ' 

22 

16 

'DATE' 

== 

17 

1 MACHTRK ' 

=  2 

18 

■MISSION' 

=2 

19 

' PKOP ' 

22 

20 

'SITE' 

23 

21 

'STAT' 

2= 

22 

'TIME' 

=* 

23 

'TITLE' 

=2 

24 

'WIDTH' 

33 

25 

'  FFT ' 

23 

26 

'STATS' 

23 

27 

•  SI  GNAT 

23 

28 

'STATONLY' 

23 

29 

'  SCRCHPAD ' 

=2 

30 

CD 

O 

23 

31 

'  PSF 

22 

32 

'NEW 

22 

33 

(STATS  EQUALS  STATS  =s  223 


INVOCATION: 


[CALL]  GETOKN  (  PI,  »2,  P3,  P4 ) 


PI  (CHARACTER*!*))  STRING  COMPOSING  THE  TOKEN 
P2  (INTEGER]  LENGTH  OF  HE  CHARACTER  STRING  (PI) 
P 3  (INTEGER]  VALUE  OF  THE  TOKEN 


> 


» 


P4  ::=  [LOGICAL]  FLAG  SIGNALING  IDENTIFIER  TYPE  REO 


VARIASLE  DICTIONARY: 


ACPTST  ;  SYMBOL  REPRESENTING  STATEMENT  LABEL  100 
BUFPOS  ;  CURRENT  POSITION  IN  THE  INPUT  BUFFER 
CHAR  ;  DUMMEY- ARGUMENT  FOR  LOGICAL  STATEMENT  FUNCTIONS 
ENDFLG  ;  FLAG  SIGNALING  THE  END  OF  FILE  ON  1  INFILE 1 
INCHAR  ;  CURRENT  INPUT  CHARACTER  FROM  BUFFER 
INFILE  ;  SOURCE  FILE  CONTAING  COOE  TO  BE  PARSED 
KWORDS  ;  TABLE  CONTAING  CERTAIN  KEYWORDS  TO  BE  RECOGNIZED 
LISTFL  ;  OUTPUT  FILE  FOR  ECHOING  SOURCE  COOE  ANO  ERRORS 
P4 

SYMBOL  REPRESENTING  STATEMENT  LABEL  1 
SYMBOL  REPRESENTING  STATEMENT  LABEL  2 
SYMBOL  REPRESENTING  STATEMENT  LABEL  3 
SYMBOL  REPRESENTING  STATEMENT  LABEL  4 
SYMBOL  REPRESENTING  STATEMENT  LABEL  5 
SYMBOL  REPRESENTING  STATEMENT  LABEL  6 
SYMBOL  REPRESENTING  STATEMENT  LABEL  7 
SYMBOL  REPRESENTING  STATEMENT  LABEL  8 
LOOP  CONTRL  VARIABLE  FOR  INDEXING  TABLE  'KUORDS' 
P2 
PI 
P3 

CALLER  MODULES: 


STATE1 

STATE2 

STATE3 

STATE4 

STATE5 

STATE6 

STATE7 

STATES 

TBLIDX 

TKNLEN 

TKNSTR 

TXNVAL 


[SUBROUT  I NE]  PRSPACKXPARSE ( ) 
CALLED  MODULES: 


[SUBROUTINE 

FUNCTION] 

[SUBROUTINE 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

[STATEMENT 

FUNCTION] 

LEXPACKNADDCHR ( ) 

LEXPACKNGETCHRO 

GET0KN\8LANKO 

GETOKN\COMMA() 

GETOKN\DIGITO 

GETOKNSHYPHENO 

GETOKN\LETTER(> 

GETOKN\PERIOOO 

GETOKNXSLASHO 


PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  10-QCT-85 

REVISIONS  :  12-NOV-86  RECOGNITION  OF  TOLKENS  1 FFT 1 ,  'STATS', 

•SIGNAT', 'STATONLY' 

SUBROUTINE  GETOKN  (TKNSTR,  TKNLEN,  TKNVAL ,  PRSCTR  ) 

EXTERNAL  GETCHR 

COMMON  /IOCOM/  INFILE,  LISTFL 


PARAMETER  (MAXKEYS=24) 


I 


INTEGER  8UFP0S,  INFILE,  LISTFL 

LOGICAL  ENDFLG,  PRSCTR 

CHARACTER*8  KWORDS(MAXKEYS) 
CHARACTER*!  GETCHR 


INTEGER 

STATE!, 

INTEGER 

STATE6, 

INTEGER 

TKNLEN, 

LOGICAL 

LETTER, 

LOGICAL 

PERIOD 

CHARACTER*! 

INCHAR, 

CHARACTERS*' 

)  TKNSTR 

STATE2,  STATES,  STATE4,  STATE5 
STATE7,  STATE8,  ACPTST,  TBL1DX 
TKNVAL 

DIGIT,  COMMA,  SLASH,  HYPHEN,  BLANK 
CHAR 


SAVE  KWORDS,  BUFPOS,  ENOFLG 
DATA  BUFPOS  /80/,  ENOFLG  /.FALSE./ 


OATA  KWORDS 

/•ACVTN 

l 

$ 

■AIRCRAFT’  , 

•ALL  • 

* 

♦ 

1 BOOMTRK 

l 

i 

•CLDN  •  , 

■CONTOUR  • 

1 

♦ 

■CSEL 

1 

/ 

■DATE  •  , 

■MACHTRK  ■ 

1 

♦ 

■MISSION 

1 

t 

■ PKOP  ■  , 

■SITE 

1 

■ST  AT 

1 

i 

•TIME  •  , 

•TITLE  • 

1 

♦ 

•WIDTH 

1 

i 

■ FFT  ■  , 

■STATS  • 

1 

♦ 

•SI  GNAT 

1 

t 

•STATONLY1  , 

‘ SCRCHPAD 1 

/ 

♦ 

CD 

O 

1 

i 

•PSF  •  , 

■NEW  ■ 

/ 

LETTER(CNAR) 

*  ( ( CHAR . GE 

DIGIT 

(CHAR) 

*  ((CHAR.GE 

COMMA 

(CHAR) 

*  (  CHAR. EG 

SLASH 

(CHAR)  : 

=  (  CHAR. EG 

HYPHEN(CHAR) 

=  (  CHAR. EG 

PERIOO(CHAR) 

=  (  CHAR.EQ 

BLANK 

(CHAR) 

=  (  CHAR.EQ 

ASSIGN 

1 

TO 

STATE! 

ASSIGN 

2 

TO 

STATE2 

ASSIGN 

3 

TO 

STATE3 

ASSIGN 

4 

TO 

STATE4 

ASSIGN 

5 

TO 

STATES 

ASSIGN 

6 

TO 

STATE6 

ASSIGN 

7 

TO 

STATE7 

ASSIGN 

8 

TO 

STATE8 

ASSIGN 

!00 

TO 

ACPTST 

TKNLEN 

*  0 

TKNSTR 

2  1 

1 

1 A 1 ) .AND . ( CHAR . LE . 'Z')> 
'0'). AND. (CHAR. LE.'9')> 

'/') 

'  ') 


C  STATE  1:  START  STATE 
1  INCHAR  =  GETCHR(BUFPOS, ENDFLG) 

C  TEST  TO  MAKE  SURE  THAT  WE  ARE  NOT  AT  THE  END  OF  THE  FILE 

IF  (ENDFLG. EQV. .TRUE.)  THEN 
TKNVAL  =  5 
RETURN 


« 


J 


« 


< 


i 


< 


« 


« 


ENO  IF 


IF  (BLANK( INCHAR) .EQV. .TRUE. )  THEN 
GO  TO  STATE1 

ELSE  IF  (LETTER(INCHAR). EOV. .TRUE.)  THEN 
GO  TO  STATE2 

ELSE  IF  (0 l GIT( INCHAR) .EQV . .TRUE . )  THEN 
GO  TO  STATE3 

ELSE  IF  ( COMMA( I NCHAR ) . EOV . . TRUE . )  THEN 
GO  TO  STATES 

ELSE  IF  (SLASH (I NCHAR). EOV. .TRUE.)  THEN 
GO  TO  STATE6 

ELSE  IF  (HYPHEN(INCHAR). EQV. .TRUE.)  THEN 
GO  TO  STATE7 

ELSE  IF  (PER 1 00 (I NCHAR). EQV. .TRUE.)  THEN. 

GO  TO  STATE8 
ELSE 

WRITE(LISTFL, 10) INCHAR 

10  FORMATdX,  '•>*- WARNING:  UNKNOWN  CHARACTER  IN  INPUT  ••>  (' 

♦  ,A, 1 )■*♦') 

TKNVAL  *  6 

RETURN 
ENO  IF 

C  STATE  2:  IDENTIFIER  STATE 
2  TKNVAL  *  7 

CALL  ADOCHR ( I NCHAR , TKNSTR , TKNLEN ) 

INCHAR  »  GETCHR(BUFPOS,ENDFLG) 

IF  ( .NOT .PRSCTR  )  THEN 

IF  ((LETTERO NCHAR ) . EOV . . TRUE . ) . OR . 

♦  (DIG1T( INCHAR) .EQV. . TRUE . ) .OR . 

♦  (HYPHEN(INCHAR). EQV. .TRUE.))  THEN 
GO  TO  STATE2 

ELSE 

GO  TO  ACPTST 
END  IF 
ELSE 

IF  ((. NOT . BLANK ( I NCHAR )). AND . C . NOT . COMMA (INCHAR)))  THEN 
GO  TO  STATE  2 
ELSE 

GO  TO  ACPTST 
END  IF 
ENO  IF 

C  STATE  3:  INTEGER  STATE 
3  TKNVAL  =  8 

IF  (PRSCTR  .EQV. .TRUE. I  THEN 
GO  TO  STATE2 
ENO  IF 

CALL  AODCHR ( I NCHAR . TKNSTR , TKNLEN ) 

INCHAR  *  GETCHR(BUFPOS,ENOFLG) 

IF  (DIGIT( INCHAR). EOV. .’RUE. )  THEN 
GO  TO  STATE3 

ELSE  IF  (PERIOO(INCHAR). EQV. .TRUE.)  THEN 
GO  TO  STATE4 


ELSE 


GO  TO  ACPTST 
END  IF 

C  STATE  4:  REAL  NUMBER  STATE 

4  TKNVAL  *  9 

CALL  AOOCHR< INCHAR,  TKNSTR,  TKNLEN) 

INCHAR  *  GETCHR(BUFPOS,ENDFLG) 

IF  (DIGITf INCHAR) .EQV. .TRUE. )  THEN 
GO  TO  STATE4 
ELSE 

GO  TO  ACPTST 
END  IF 

C  STATE  5:  COMMA  STATE 

5  TKNVAL  a  1 

CALL  AOOCHRC INCHAR ,TKNSTR , TKNLEN) 

GO  TO  ACPTST 

C  STATE  6:  SLASH  STATE 

6  TKNVAL  »  2 

CALL  ADDCHRC INCHAR, TKNSTR , TKNLEN ) 

GO  TO  ACPTST 

C  STATE  7:  HYPHEN  STATE 

7  TKNVAL  •  3 

CALL  AOOCHR ( I NCHAR , TKNSTR , TKNLEN ) 

GO  TO  ACPTST 

C  STATE  8:  PERIOO  STATE 

8  TKNVAL  a  4 

CALL  AOOCHR< INCHAR,  TKNSTR,  TKNLEN) 

GO  TO  ACPTST 

C  ACPTST  :  ACCEPT  STATE 

C  CHECK  IF  THE  SUFFER  POINTER  SHOULD  BE  RETRACTED. 

100  IF  ((. NOT. BLANK(INCHAR)). AND. (TKNVAL. GE. 7))  THEN 

8UFPOS  S  BUFPOS  -  1 
END  IF 

IF  (TKNVAL. EO. 7)  THEN 

00  101  T8LI0X  a  1,  MAXKEYS 

I F(KUORDS(TBL IOX) ,EQ. TKNSTRC 1 :8) )  THEN 
TKNVAL  =  T8LIDX  ♦  9 
ENO  IF 

C  CHECK  IF  THE  TOLKEN  IS  'STATS'  IF  SO  THEN  TKNVAL  EQUALS  22 

C  THIS  IS  DUE  TO  THE  FACT  THAT  'STAT'  AND  'STATS'  ARE  EQUAL 

IF  ( TKUVAL  ,EQ.  27)  THEN 
TKNVAL  a  22 
END  IF 

101  CONTINUE 
ENO  IF 


PRSCTR 


.FALSE. 


RETURN 
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»>»  END  IEXPACX  ««< 


MODULE  NAME:  PRSPACK 
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MODULE  NAME:  PRSPACK 
MOOULE  TYPE:  PACKAGE 

OVERVIEW: 

THIS  PACKAGE  IS  USED  TO  PERFORM  THE  PARSING  OF  THE  SOURCE 
FILE  'INFILE'.  THE  METHOO  OF  PARSE  IS  A  SIMPLE  TABLE  DRIVEN 
PARSE.  THE  PARSE  TABLE  IS  INITIAILIZED  IN  THE  BLOCK  DATA  SUB¬ 
ROUTINE  'PRSOAT' .  THE  PARSE  TABEL  CONSISTS  OF  THE  STATE  TRAN¬ 
SITIONS  FOR  INPUT  TOKENS.  EACH  TIME  AN  INPUT  TOKEN  IS  RETURNED 
BY  '  LEXPACK\GETOKN O',  SUBROUTINE  ‘PRSPACKUOOKUPO '  IS  CALLED 
TO  DETERMINE  THE  NEXT  STATE  TO  GO  TO  8Y  REFERNCING  THE  PARSE  TABL 
WITH  THE  CURRENT  STATE  VERSUS  THE  CURRENT  INPUT  TOKEN  VALUE. 
PROGRAM  EXECUTION  THEN  TRANSFERS  TO  A  STATEMENT  LABEL  REPRESENTIN 
THAT  STATE,  WHERE  VARIOUS  SEMANTIC  ACTIONS  A  PERFORMED  TO  STORE  T 
THE  INFORMATION  IN  INTERNAL  DATA  STRUCTURES. 

INTERFACE: 

PARSE  C  PI  ) 

PI  [LOGICAL]  FUG  REPRESENTING  A  FATAL  PARSE  ERROR 

INTERNAL  SUBROUTINE  &  FUNCTIONS: 

LDATEC)  ;  RETURNS  TRUE  If  A  MONTH,  DAY,  OR  YEAR  IS  LEGAL 

LTIMEO  ;  RETURNS  TURE  IF  A  TIME  IS  LEGAL 

LOOKUPO  ;  TRANSFERS  PROGRAM  CONTROL  TO  THE  NEXT  STATE 

PRSOAT  ;  NON -EXECUTABLE.  SETS  THE  PARSE  TABLE  VALUES 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  14-OCT-85 

REVISIONS:  1 1  -  NOV • 86  NEW  STATES  ’ FFT SI  GNAT ',' STATONLY ' 
SHARED  DATA: 

BLOCK  DATA  PRSOAT 
COMMON  /PRSCOM/  PT 
INTEGER  PT (59,33) 

C-  INITIALIZE  THE  PARSE  TABLE. 

DATA  PTC  1,21)  /  2/,  PTC  1,24)  /47/ 

DATA  PTC  2,12)  /  5/,  PTC  2,  7)  /  3/ 

DATA  PT(  3,17)  /  6/,  PTC  3,19)  /  7/,  PTC  3,  1)  /  4 / 

DATA  PT{  4,  7)  /3/ 

OATA  PTC  5,17)  /  6/,  PTC  5,19)  /  7/ 

DATA  PT(  6,12)  /10/,  PTC  6,  3)  /II/ 

OATA  PTC  7,12)  /23/,  PTC  7,  7)  /  8/ 


DATA  PT(  8,23)  /24/,  PTC  8,  1)  /  9/ 

DATA  PTC  9,  7)  /  8/ 

OATA  PT(10,23)  /24/ 

DATA  PTC11,  2)  /12/ 

DATA  PTC  12,  8)  /13/ 

OATA  PTC  13,  2)  /14/ 

DATA  PTC14,  8)  /IS/ 

DATA  PTC15.23)  /24/,  PTC15,  1)  /22/,  PT CIS,  3)  /16/ 
OATA  PTC  16,  8)  /17/ 

OATA  PTC  17,  2)  /18/ 

DATA  PTC18,  8)  /19/ 

DATA  PTC  19,  2)  /20/ 

DATA  PTC20,  8)  /21/ 

OATA  PTC21 ,23)  /24/,  PVC21 ,  1)  /22/ 

DATA  PTC22,  8)  /II/ 

DATA  PTC 23, 23)  /24/ 

OATA  PTC24.12)  /2 9/,  PTC24,  8)  /25/ 

OATA  PTC25.10)  /30/,  PTC25.11)  /31/,  PTC2S,  1)  /28/, 
PTC 25,  3)  /26/ 

DATA  PTC 26,  8)  /27/ 

DATA  PTC27.10)  /30/,  PTC27.11)  /31/,  PTC 27,  1)  /28 / 
DATA  PTC28,  8)  /25/ 

DATA  PTC29.10)  /30/,  PTC29.11)  /3 1/ 

DATA  PTC30.12)  /37/,  PTC30,  7)  /34/ 

DATA  PTC31.12)  /38/,  PTC31,  7)  /32/ 

DATA  PTC32.13)  /40/,  PTC32.15)  /44/,  PTC32.18)  /42/, 
PTC32.21)  /  2/,  PTC32.22)  /39/,  PTC32,  1)  /33/, 
PTC32,  5)  /53/,  PTC32.25)  /SO/ 

DATA  PTC 33,  7)  /32/ 

DATA  PTC34,  7)  /35/ 

DATA  PTC35.13)  /40/,  PTC35.15)  /44/,  PTC35.18)  /42/, 
PTC35.21)  /  2/,  PTC35.22)  /39/,  PTC35,  1)  /36/, 
PTC 35,  5)  /53/,  PTC35.25)  /50/,  PTC35.26)  /54/, 
PTC35.28)  /55/,  PTC35.29)  /56/,  PTC35.30)  /57/ 
DATA  PTC36,  7)  /34/ 

DATA  PTC37.13)  /40/,  PTC37.15)  /44/,  PTC37.18)  /42/, 
PTC37.21)  /  2/,  PTC37.22)  /39/,  PTC37,  5)  /53/, 
PTC37.2S)  /SO/,  PTC37.26)  /54/,  PTC37.28)  /55/, 
PTC37.29)  /56/,  PTC37.30)  /57/ 

DATA  PTC38, 13)  /40/,  PTC38.15)  /44/,  PT(38,18)  /42/, 
PTC38.21)  /  2/,  PTC38.22)  /39/,  PT ( 38 ,  5)  /53/, 
PTC38.25)  /50/,  PTC38.26)  /54/,  PTC38.28)  /55/, 
PTC38, 29)  /56/,  PTC 38, 30)  /57/ 

OATA  PTC39.13)  /40/,  PTC39, 15)  /44/,  PT(39,18)  /42/, 
PT(39,21)  /  2/,  PTC 39,  5)  /53/,  PTC39.25)  /50/, 
PTC39.26)  /54/,  PTC39.28)  /55/,  PTC39.29)  /56/, 
PTC39.30)  /57/ 

DATA  PTC 40,  8)  /4 1 / ,  PTC40,  9)  /41/ 

DATA  PT (41 ,15)  /44/,  PTC41.18)  /42/,  PTC41.21)  /  2/, 
PT (41 ,22)  /39 /,  PT(41,  5)  /53 /,  PTC41.25)  /50/, 
PT (41 ,26)  /54/,  PT (41 , 28 )  /55/,  PT(41,29)  /56/, 
PTC41.30)  /5 7/ 

DAT*  PTC 42,  8)  /43/,  PT(42,  9)  /43/ 

DATA  PT(43, 13)  /40/,  PT(43,15)  /44/,  PTC43.21)  /  2/, 


PTC43.22)  /39/,  PT(43,  5)  /53/,  PT(43,25)  /SO/, 
PT(43,26)  /54/,  PT(43,28)  /55/,  PTC43.29)  /56/, 
PT (43,30)  /57/ 

DATA  PT(44,14)  /49/,  PT(44,16)  /49/,  PT(44,20)  /49/ 
DATA  PT(45, 13)  /40/,  PT<45,18)  /42/,  PTC45.21)  /  2/, 
PT(45,22)  /39/,  PT(45,  1)  /46/,  PT(45,  5)  /53/, 
PT(45,2S)  /SO/,  PT(45, 15)  /44/,  PT<45,26)  /54/, 
PT (45,28)  /55/,  PT<45,29)  /56/,  PTC45.30)  /57/ 
DATA  PTC46,  8)  /45/,  PT<46,  9)  /45/ 

DATA  PT (47,  7)  /48/,  PT<47,  8)  /43/,  PT<47,  9)  /48/, 

PT<47,  1)  /48/,  PT<47,  2)  /48/,  PT(47,  3)  /48/, 

PT(47,  4)  /48/,  PT(47,10)  /48/,  PTC47.11)  /48/, 
PT(47,12)  /48/,  PTC47, 13)  /4 8/,  PT<47,14)  /48/, 
PT(47,15)  /48/,  PT(47,16)  /48/,  PTC47.17)  /48/, 
PT(47,18>  /48/,  PT(47, 19)  /4 8/,  PTC47.20)  /48/, 
PT<47,21)  /48/,  PT<47,22)  /48/,  PT(47,23)  /48/, 

PT(47,24)  /48/,  PT(47,25)  /48/ 

DATA  PT (48,21 )  /  2/,  PT(48,  7)  /48/,  PT<48,  8)  /48/, 

PTC48,  9)  /48/,  PT<48,  1)  /48/,  PT(48,  2)  /48/, 

PT (48,  3)  /48/,  PT(48,  4)  /48/,  PT(48,10)  /48/, 
PTC48, 11 )  /48/,  PT (48, 12}  /48/,  PT(48,13)  /48/, 
PT(48, 14)  /48/,  PT(48, 15)  /48/,  PT<48,16)  /48/, 

PT(48,17)  /48/,  PT(48,18)  /48/,  PT(48,19)  /48/, 

PT<48,20)  /48/,  PT<48,225  /48/,  PT(48,23)  /48/, 

PT(48,24J  /4fl/,  PT(48,25)  /48/ 

DATA  PT(49,  1)  /52/ 

DATA  PT(50,  8)  /5 1 / ,  PT<50,  9)  /51/ 

DATA  PT(51 ,  5)  /53/,  PT(51 , 13)  /40/,  PT(51,15>  /44/, 
P TC51, 18}  /42/,  PT(51 ,22)  /39/,  PT(51,26)  /54/, 
PT(51 ,28)  /55/,  PT(51,29)  /56/,  PT(51,30)  /57/ 
DATA  PT(52,  8)  /45/,  PT(52,  9)  /45/ 

DATA  PT<54,22)  /39/,  PT<54,13)  /40/,  PT(54,18)  /42/, 
PT(54,15)  /44/,  PT<54,25)  /SO/,  PT<54,  5)  /53/, 
PT(54,21)  /  2/,  PT(54,28)  /55/,  PT<54,29)  /56/, 
PT(54,30)  /57/ 

DATA  PT<55,26)  /54/,  PT(55,22)  /39/,  PT(55,13)  /40/, 

PT<55,  5)  /53/,  PT(S5, 18)  /42/,  PT(55,29)  /56/, 

PT(55,15)  /44/,  PT(55,25)  /50/,  PT(55,21)  /  2/, 
PT(55,30)  /57/ 

DATA  PT(56,26)  /54/,  PT{56,22)  /39/,  PT(56,13)  /40/, 

PT(56,  5)  /53/,  PT<56, 18)  /42/,  PT(56,28)  /55/, 

PT(56, 15)  /44/,  PT<56,25)  /50/,  PT(56,21)  /  2/, 
PT<56,30)  /57/ 

DATA  PT(57,31 )  /58/,  PT(57,32)  /58/ 

OATA  PT(S8,26)  /S4/,  PT(58,22)  /39/,  PT(58,13)  /40/, 

PTC58,  5)  /53/,  PT < 58 ,18)  /42/,  PT(58,28)  /55/. 

PTC58.15)  /44/,  PTC 58, 25)  /50/,  PT(58,21)  /  2/, 
PTC58.29)  /56/,  PT<58,33)  /59/,  PTC58.12)  /59/ 
OATA  PT(59, 26)  /54 /,  PT(59, 22)  /39/,  PTC59,13)  /40/, 

PTC59,  5)  /53/ ,  PT ( 59 , 18)  /42/,  PT(59,28)  /55/, 

PTC59.15)  /44/ ,  PTC 59 , 25 )  /50/,  PT(59,21)  /  2/, 
PTC59.29)  /56/ 


MOOULE  NAME :  PRSPACKXLDATE 

MOOULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 


OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  CHECK  IF  A  CERTAIN  PART 
(I.E.  MONTH,  DAT,  YEAR)  IS  LEGAL  ACCORDING  THE  INTEGER  BOUNDS 
PERTAINING  TO  THAT  PART  OF  THE  DATE. 

INVOCATION: 

tX  *  )  LDATE  (  PI,  P2  ) 

PI  [CHARACTER*2I  STRING  SPECIFYING  SEGMENT  TO  TEST 
P2  ::*  [CHARACTER*!*))  STRING  HOLDING  THE  DATE 

VARIABLE  DICTIONARY: 

FRAG  ;  PI 
FRGSTR  ;  P2 

T STINT  ;  INTEGER  VARIABLE  USED  TO  COMPARE  BOUNDS 
CALLER  MOOULES: 

[SUBROUTINE!  PRSPACKVPARSEO  . 

CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  14 -OCT -85 

REVISIONS  : 

LOGICAL  FUNCTION  LDATELFRAG,  FRGSTR) 

CHARACTER*2  FRAG 
CHARACTER*!*)  FRGSTR 
INTEGER  TSTINT 

CONVERT  THE  CHARACTER  STRING  TO  AN  INTEGER 
READ ! FRGSTR !1 :2) , FMT=' ! 1 2 ) * ) TSTINT 

IF  ! FRAG. EG . 'MM' )  THEN 
CHECK  IF  A  LEGAL  MONTH 

LDATE  =  ((TSTINT. GE.1). AND. [TSTINT. LE. 12)) 

ELSE  IF  (FRAG.EO. 'DO' )  THEN 
CHECK  IF  A  LEGAL  DAY 

LDATE  =  ((TSTINT. GE.D.ANO. (TSTINT. LE. 31)) 


ELSE  IF  (FRAG.E9. 1 YY* )  THEN 
CHECK  IF  A  LEGAL  YEAR 

LDATE  *  ((TSTINT.GE. 1 ) .AND. (TSTINT .LE.99)) 
END  IF 
RETURN 


MODULE  NAME:  PRSPACtCNLTIME 

MODULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  SUBROUTINE  FUNCTION  IS  USED  TO  TEST  IF  THE  TIME  SPECIFI 
IS  WITHIN  THE  MILITARY  BOUNDS  OF  000! -2400  HOURS. 

INVOCATION: 

£X  *  ]  LTIME  (  PI  ) 

PI  ::  =  [INTEGER]  TIME  INPUT  FOR  TESTING 
VARIABLE  DICTIONARY: 

INTIME  ;  PI 
CALLER  MOOULES: 

[SUBROUTINE]  PRSPACKXPARSEO 
CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  1 4  - OCT  -  85 

REVISIONS  : 

LOGICAL  FUNCTION  LTIHE( INTIME ) 

LTIME  *  ((INTIME. GE. 0001). AND. (INTIME. LE. 2400)) 

RETURN 

END 


MODULE  NAME:  PRSPACK\LOOKUP 
MODULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  ACCESS  THE  PARSING  TABLE  BASED  ON 
THE  CURRENT  INPUT  TOKEN  VALUE  AND  THE  CURRENT  STATE  OF  THE  PARSER 
THE  CURRENT  STATE  OF  THE  PARSER  IS  UPOATED  AND  THEN  AN  ALTERNATE 
RETURN  IS  PROCESSED  BASED  ON  THE  CURRENT  STATE  OF  THE  PARSER. 

INVOCATION: 

CCALL3  LOOKUP  <  PI,  P2,  AR  ) 

PI  ::*  CURRENT  STATE  OF  THE  PARSER 
P2  ::*  CURRENT  INPUT  TOKEN  VALUE 
AR  ::■  ALTERNATE  RETURNS  TO  NEXT  STATE 

VARIA8LE  DICTIONARY: 


CURST 

;  CURRENT  STATE  OF  THE  PARSER 

INPUTV 

I  P2 

NEXTST 

;  PI 

PT 

;  PARSE  TABLE 

CALLER  MOOULES: 

C SUBROUTINE]  PR«PACK\PARSEO 
CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  14-OCT-85 

REVISIONS  :  11 -NOV-86  NEW  STATES  FOR  1 FFT ' , 1 SIGNAT 1 , ' STATONLY ' 

SUBROUTINE  LOOKUPINEXTST,  INPUTV,  *,  *,  *,  *,  *,  *,  *,  *,  *, 


) 


COMMON  /PRSCOM/  PT 

INTEGER  PT(59,33) 

INTEGER  NEXTST,  INPUTV,  CURST 

CURST  *  NEXTST 

NEXTST  *  PT (CURST , INPUTV) 


RETURN  PT(CUR$T , INPUTV) 


END 


BLOCK  DATA  BGETRC 

INTEGER  TIMENM,  MXDATE  ,  MXMSSN  ,  MXPLNS  ,  MXREPS 
INTEGER  MXSITE  ,  MXTIME  ,  TKNVAL  ,  TKNLEN  ,  LISTFL 

PARAMETER(MXDATE=10,  MXMSSN«10,  MXPLNS=10, 

►  MXREPS-5  ,  MXSITE=20,  MXTIME=10, 

►  MXCONT=20  ) 

NAMED  COMMON:  CHRTABS-  DATA  COMMUNICATION  TO  SCHPACK\GETREC 
COMMON  /CHRTABS/  ARCRFT ,  MSSNS,  SITES,  TAILNM 

NAMED  COMMON:  INTTABS-  OATA  COMMUNICATION  TO  SCHPACK\GETREC 
COMMON  /INTTABS/  ENOATE,  ENTIME,  STDATE,  STTIME,  REPNUM 


INTEGER 

CHARACTER*6 

INTEGER 

INTEGER 

CHARACTERS 

CHARACTER'10 

INTEGER 

INTEGER 

CHARACTER'S 


REPNUM 

ARCRFT  (MXREPS,  MXPLNS) 
ENOATE  (MXREPS,  MXDATE) 
ENTIME  (MXREPS,  MXTIME) 
MSSNS  (MXREPS,  MXMSSN) 
SITES  (MXREPS,  MXSITE) 
STDATE  (MXREPS,  MXDATE) 
STTIME  (MXREPS,  MXTIME) 
TAILNM  (MXREPS,  MXPLNS) 


DATA  ARCRFT  /50*'  •/ 
DATA  ENOATE  /50*0  / 
OATA  ENTIME  /50*2359/ 
OATA  MSSNS  /SO*'  '/ 
DATA  SITES  /100» •  •/ 
DATA  STDATE  /50*0  / 
DATA  STTIME  /50*0  / 
DATA  TAILNM  /SO*'  •/ 


END 


MODULE  NAME:  PRSPACKXPARSE 
MODULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  PARSE  THE  INPUT  FILE  1  INFILE 1 
BY  MEANS  OF  A  TABLE  DRIVEN  PARSER.  UPON  REACHING  THE  CURRENT 
STATE  OF  THE  PARSER  VARIOUS  SEMANTIC  ACTIONS  ARE  PERFORMED  TO 
STORE  THE  DATA  IN  ‘  INFILE1  IN  INTERNAL  DATA  STRUCTURES  FOR  LATER 
USE. 

INVOCATION: 

[CALL]  PARSE  <  PI,  P2  ) 

PI  ::  =  [CHARACTER*^]]  STRING  CONTAINING  THE  RUN  TITLE 
P2  ::*  [LOGICAL]  FLAG  SIGNALING  A  FATAL  PARSE  ERROR 

VARIABLE  DICTIONARY: 


ACNUM 

ARCRFT 

BOOMFL 

BOOMVA 

CONTFL 

CONTRL 

CURST 

DTENUM 

ENDATE 

ENT  I ME 

ERRORF 

FFT 

INTEST 

LOOP 

LISTFL 

MACHFL 

MACHVA 

MSSNS 

MSSNUM 

MXOATE 

MXMSSN 

MXPLNS 

MXREPS 

MXSITE 

MXTIME 

RAYTRA 

SIGNAT 

SITES 

STATFL 

SITENM 

STDATE 


NUMBER  OF  AIRCRAFT  LISTED 

TABLE  CONTAINING  AIRCRAFT  TYPES 

.TRUE.  IF  BOOMVAL  IS  SPECIFIED 

CONTAINS  THE  BOOM  VALUE  SPECIFIED  IN  INFILE 

.TRUE.  IF  CONTVAL  IS  SPECIFIED 

SWITCH  TO  CONTROL  THE  LEXICAL  ANALYZER 

CURRENT  STATE  OF  THE  TABLE  DRIVEN  PARSER 

NUMBER  OF  OATES  LISTED 

TABLE  CONTAINING  THE  ENO  DATES 

TABLE  CONTAINING  THE  END  TIMES 

PH 

BOOLEAN  FLAG  FOR  FFT  VALUES. 

VARIABLE  USED  TO  TEST  INTEGER  VALUES 

SYMBOL  REPRESENTING  STATEMENT  LABEL  #1 

OUTPUT  FILE  FOR  ERRORS  AND  SOURCE  COOE  ECHO 

.TRUE.  IF  MACHVAL  IS  SPECIFIED 

CONTAINS  2-10  MACH  VALUES 

TABLE  CONTAINING  MISSION/EXERCISE  NAMES 

NUMBER  OF  MISSIONS  LISTED 

MAXIMUM  NUMBER  OF  DATES  ALLOWED 

MAXIMUM  NUMBER  OF  MISSIONS  ALLOWED 

MAXIMUM  NUMBER  OF  PLANES  ALLOWED 

MAXIMUM  NUMBER  OF  REPETITIONS  OF  INPUT  UNITS 

MAXIMUM  NUMBER  OF  SITES  ALLOWED 

MAXIMUM  NUMBER  OF  TIMES  ALLOWED 

BOOLEAN  FLAG  FOR  STATONLY  VALUES 

BOOLEAN  FLAG  FOR  SIGNATURE  VALUES 

TABLE  CONTAINING  THE  SITE  LOCATIONS 

.TRUE.  IF  STATS  ARE  TO  BE  PRINTED 

NUM8ER  OF  SITE  LOCATIONS  LISTED 

TABLE  CONTAINING  THE  START  DATES 


STTIME 

TAILNM 

TIMENM 


TABLE  CONTAINING  THE  START  TIMES 

TABLE  CONTAINING  THE  AIRCRAFT  TAIL  NUMBERS 

NUMBER  OF  START  AND  END.  TIMES  LISTED 


CALLER  MGOULES: 

MAIN  DRIVER  ROUTINE 

CALLED  MOOULES: 

tSUBROUT  I NE]  LEXPACK\GETOt(N  <  > 

[SUBROUTINE  FUNCTION]  PRSPACKNLDATEO 
[INTRINSIC  FUNCTION  ]  LENO 
[SUBROUTINE]  LEXPACKUOOKUPO 
[SUBROUTINE  FUNCTION]  PRSPACXNLTIMEO 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  14-OCT-85 

REVISIONS  :  31 -OCT -85  IMPLEMENTED  HANDLING  OF  TITLE  CARD 

1 1 ■ NOV - 86  IMPLEMENTED  NEW  STATES  1 FFT 1 , ' SIGNAT ' , 
'STATONLY'. 

SUBROUTINE  PARSE  (  TITLE  ,  ERRORF  ) 

EXTERNAL  LOATE,  LTIME 

INTEGER  TIMENM,  MXOATE  ,  MXHSSN  ,  MXPLNS  ,  MXREPS 
INTEGER  MXS1TE  ,  MXTIME  ,  TXNVAL  ,  TJCNLEN  ,  LISTFL 

PARAMETER (MX0ATE=10,  MXMSSN=10,  MXPLNS=10, 

+  MXREPS=5  ,  MXSIT£=20,  MXTIME=10, 

♦  MXCONT=20  > 

NAMED  COMMON:  STATS-  DATA  COMUNI  CAT  I ON  TO  MAIN  DRIVER  ONLY! 
COMMON  /STATS/  STATFL,  SOOMFL,  MACHFL,  CONTFL,  BOOMVA, 

♦  MACHVA,  CONTVA,  CONTYP,  WIDTH,  FFT,  SIGNAT, 

♦  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 

NAMED  COMMON:  CHRTABS-  DATA  COMMUNICATION  TO  SCHPACK\GETREC 
COMMON  /CHRTABS/  ARCRFT ,  MSSNS,  SITES,  TAILNM 

NAMED  COMMON:  INTTABS-  DATA  COMMUNICATION  TO  SCHPACKNGETREC 
COMMON  /INTTABS/  ENDATE,  ENTIME,  STDATE,  STTIME,  REPNUM 

INTEGER  ACNUM  ,  DTENUM  ,  MSSNUM  ,  REPNUM  ,  SITENM 
INTEGER  CURST  ,  T8LNUM  ,  COL  ,  PRNTROW,  CONTREP 

INTEGER'  CONTYPTMXREPS) 

REAL  800MVA ,  MACHVA,  WIDTH  ,  CONTVA(MXREPS,MXCCNT) 
CHARACTER*20  TXNSTR 
CHARACTER*91  LSTBUFF 
CHARACTER*!*)  TITLE 

LOGICAL  LDATE  ,  LTIME  ,  ERRORF  ,  CONTRL 

LOGICAL  STATFL,  BOOMFL,  MACHFL,  CONTFL,  FFT,  SIGNAT, 

♦  RAYTRC,  TCSEL,  SCRPAD,  SCRPSF,  SCRALL 


CHARACTER*6  ARCRFT  (MXREPS,  MXPLNS) 

INTEGER  ENDATE  (MXREPS,  MXOATE) 

INTEGER  ENT1ME  (MXREPS,  MXTIME) 

CHARACTER* 16  MSSNS  (MXREPS,  MXMSSN) 

CHARACTER’IO  SITES  (MXREPS,  MXSITE) 

INTEGER  STOATE  (MXREPS,  MXOATE) 

INTEGER  STTIME  (MXREPS,  MXTIME) 

CHARACTER'S  TAIINM  (MXREPS,  MXPLNS) 

OATA  USTFL  /6/ 

ASSIGN  1  TO  LOOP 
ASSIGN  1550  TO  PRNTROU 

TCSEL  »  .FALSE. 

ERROR F  *  .FALSE. 

CONTRL*  .FALSE. 

FFT  *  .FALSE. 

SI  GNAT  *  .FALSE. 

RAYTRC  »  .FALSE. 

SCRPAD  -  .FALSE. 

SCRPSF  *  .FALSE. 

SCRALL  *  .FALSE. 

CURST  ■  1 
REPNUM  *  0 
TITLE  »  1  • 

CONTREP  »  0 
WIDTH  <■  30.0 
DO  7  I  *  T,  MXREPS 
DO  6  J  =  1,  MXCONT 
CONTVA( I , J )  *  0.0 

6  CONTINUE 

7  CONTINUE 

C  LOOP:  PARSE  AND  STORE  UNTIL  THE  ACCEPT  STATE  HAS  BEEN  REACHED. 

1  IF  (ERRORF.EOV. .TRUE . )  RETURN 

CALL  GETOKN(TKNSTR,  TXNLEN,  TKNVAL ,  CONTRL) 

CALL  LOOKUP(CURST,  TKNVAL, 

♦  *10  ,  *20  ,  *30  ,  *40  ,  *50  ,  *60  .  *70  ,  *80  ,  *90  ,  *100, 

+  *110,  *120,  *130,  *140,  *150,  *160,  *170,  *180,  *190,  *200, 

♦  *210,  *220,  *230,  *240,  *250,  *260,  *270,  *280,  *290,  *300, 

♦  *310,  *320,  *330,  *340,  *350,  *360,  *370,  *380,  *390,  *400, 

♦  *410,  *420,  *430,  *440,  *450,  *460,  *470,  *480,  *490,  *500, 

♦  *510,  *520,  *530,  *525,  *527,  *528,  *535,  *537,  *538  ) 

C  STATE  0  :  ERROR  STATE. 

UR  I TE(L I STFL , FMT *3)  TKNSTR( 1 : TKNLEN ) 

3  FORMAT(5X,  '**-FATAL  SYNTAX  ERROR  ON  INPUT  "\A, 

♦  (PARSE  TERMINATED)-**' ) 

ERRORF  *  .TRUE. 

GO  TO  LOOP 


C  STATE  1  :  START  STATE 


10 


GO  TO  LOOP 


C  STATE 

20 


21 


C  STATE 

30 

31 


32 


C 


C  STATE 
40 

C  STATE 
C 

50 


C  STATE 
C 

60 


C  STATE 

7C 

C 


:  RECOGNIZED  'SITE' 

REPNUM  «  REPNUM  ♦  1 
IF  { REPNUM. GT.MXREPS)  THEN 
WRITE(LISTFL,21) 

FORMAT ( •  **-UARNING:  TOO  MANY  SITE  CARO  REPETITIONS-**' ) 
ERROR F  =  .TRUE. 

ELSE 

ACNUM  «  0 
DTENUM  *  0 
MSSNUM  *  0 
SITENM  *  0 
TIMENM  *  0 
END  IF 

GO  TO  LOOP 

:  FOUND  IDENTIFIER  AFTER  'SITE' 

IF  (TKNLEN.GT.LEN(SITES(1 ,  1)))  THEN 
URITE(LISTFL, FMT=31 ) 

FORMAT ( 1  **• ERROR:  SITE  NAME  TOO  LONG!-**') 

ERRORF  «  .TRUE. 

ERRORF  *  .TRUE. 

ELSE  IF  (SITENM. GE.MXSITE)  THEN 
URITE(LISTFL.FMT*32) 

FORMAT ( '  **-UARNING:  TOO  MANY  SITES  LISTED-**') 

ERRORF  »  .TRUE. 

ERRORF  »  .TRUE. 

ELSE 

STORE  THE  SITE  NAME  IN  THE  SITE  LOCATION  TABLE 
SITENM  =  SITENM  +  1 

SITES  (REPNUM,  SITENM)  =  TKNSTRO  :LEN(SITES(  1,1))) 

END  IF 
GO  TO  LOOP 

:  IDENTIFIER  LIST  FOR  SITE  LOCATIONS  BEING  PROCESSED 
GO  TO  LOOP 

:  'ALL'  SITE  LOCATIONS  ARE  TO  BE  INCLUDED 
STORE  'ALL'  IN  SITE  LOCATION  TABLE 
SI TES(REPNUM ,  1)  *  'ALL' 

GO  TO  LOOP 

:  'DATE'  RECOGNIZED 

THEREFORE  ALL  MISSION  NAMES  ARE  VALID 

MSSNS ( REPNUM , 1 )  *  'ALL' 

GO  TO  LOOP 

7  :  'MISSION'  RECOGNIZED 
CONTRL  =  .TRUE. 

ALL  DATES  ARE  VALID. 

STDATE(REPNUM, 1 )  =  9999 
ENOATE(REPNUM, 1 )  *  9999 


GO  TO  LOOP 


C  STATE 
SO 

81 

82 

C 

C  STATE 
90 

C  STATE 
100 

C  STATE 
110 

111 

112 


C  STATE 
120 

C  STATE 

130 

131 


8  :  FOUND  AN  IDENTIFIER  AFTER  'MISSION1 
IF  (TKNLEN.GT.LEN(MSSNS(1 , 1 )))  THEN 

WRITE(LISTFL, FMT =81 ) 

FORMA T< '  **- ERROR:  MISSION  NAME  TOO  LONG-**1 ) 

ERRORF  s  .TRUE. 

ELSE  IF  ( MSSNUM . GE . MXMSSN )  THEN 
WRITECLISTFL, FMT*82) 

FORMAT ( 1  -m-WARNING:  TOO  MANY  MISSIONS  LISTED-++* ) 
ERRORF  >  .TRUE. 

ELSE 

STORE  THE  MISSION  NAME  IN  THE  TABLE 
MSSNUM  >  MSSNUM  *  1 

MSSNSCREPNUM, MSSNUM)  *  TKNSTRC1 :LEN(MSSNS(1 ,  1  >)) 

ENO  IF 
GO  TO  LOOP 

9  :  IDENTIFIER  LIST  FOR  MISSION  BEING  PROCESSED. 

CONTRL  ■  .TRUE. 

GO  TO  LOOP 

10:  ‘ALL1  DATES  ARE  TO  BE  INClUOED. 

STDATECREPNUM,  1)  3  9999 
ENOATECREPNUM,  1)  3  9999 
GO  TO  LOOP 

11:  MONTH  OF  START  OATE  RECOGNIZED. 

IF  (.NOT.LOATEC'MM'.TKNSTR))  THEN 
URITE(LISTFL,FMT3l11) 

FORMAT ( 1  **• ERROR:  ILLEGAL  MONTH  IN  START  DATE-**') 
ERRORF  3  .TRUE. 

ELSE  IF  (DTENUM . GE . MXDATE )  THEN 
URITECLISTFL,FMT*112) 

FORMAT ( 1  **-UARNING:  TOO  MANY  DATES  LISTED-**-') 
ERRORF  3  .TRUE. 

ELSE 

DTENUM  3  DTENUM  ♦  1 

READ(TKNSTR( 1 :2) , FMT*' C 12) ' )  INTEST 

STDATECREPNUM, DTENUM)  «  STDATECREPNUM, DTENUM)  + 

< INTEST  •  100) 

ENO  IF 
GO  TO  LOOP 

12:  MM  '/'  OF  START  OATE  RECOGNIZED. 

GO  TO  LOOP 

13:  DAY  OF  START  DATE  RECOGNIZED 
IF  C.NOT.LDATEC'DD'.TKNSTR))  THEN 
URITE(LISTFL,FMT=131) 

FORMAT C ’  **- ERROR:  ILLEGAL  DAY  IN  START  DATE-**') 
ERRORF  =  .TRUE. 

ELSE 

REAOCTKNSTRC 1 :2) , FMT*' ( 12) • )  INTEST 


STDATE(REPNUM, OTENUM)  *  STDATE( REPNUM .OTENUM )  +  INTEST 
ENO  IF 
GO  TO  LOOP 


C  STATE  14:  MM/OO  ■/'  OF  START  DATE  RECOGNIZED. 
140  GO  TO  LOOP 


C  STATE  15:  YEAR  OF  START  OATE  RECOGNIZED. 

150  IF  (.NOT.LDATECYY*  .TKNSTR))  THEN 

WRITE(L1STFL,FMT«151) 

151  FORMAT ('  **• ERROR:  ILLEGAL  YEAR  IN  START  DATE-**' ) 
ERRORF  ■  .TRUE. 

ELSE 

READ(TKNSTR(1 :2), FMT=* ( 12) 1 )  INTEST 

STDATE (REPNUM , OTENUM )  =  STDATE (REPNUM, DTENUM)  ♦ 

♦  (INTEST  *  10000) 

C  ASSUME  THAT  NO  ENO  DATE  IS  SPECIFIED  BY  USER 

ENOATE(REPNUM,DTENUM)  »  STDATE (REPNUM, DTENUM) 

ENO  IF 
GO  TO  LOOP 

C  STATE  16:  BETWEEN  START  AND  ENO  DATE  RECOGNIZED. 

160  GO  TO  LOOP 


C  STATE  17:  MONTH  OF  ENO  DATE  RECOGNIZED. 

170  IF  ( . NOT . LDATE ( 1 MM 1 , TKNSTR ) )  THEN 

WRITE(LISTFL,  FMT*171 ) 

171  FORMAT ( 1  "-ERROR:  ILLEGAL  MONTH  IN  END  DATE-**') 
ERRORF  ■  .TRUE. 

ELSE 

READ ( TKNSTR ( 1 :2) , FMT=' ( 12) ' )  INTEST 
ENOATE( REPNUM, OTENUM)  =  0 

ENDATE(REPNUM, OTENUM)  *  ENDATE(REPNUM, OTENUM)  + 

♦  (INTEST  *  100) 

ENO  IF 
GO  TO  LOOP 

C  STATE  18:  MM  ■/'  OF  ENO  OATE  RECOGNIZED. 

180  GO  TO  LOOP 


C  STATE  19:  DAY  OF  ENO  OATE  RECOGNIZED. 

190  IF  (.NOT.  LDATE  COD' .TKNSTR))  THEN 

WRITE(LISTFL, FMT»191 ) 

191  FORMAT  ( '  "-ERROR:  ILLEGAL  DAY  IN  ENO  DATE-"') 

ERRORF  =>  .TRUE. 

ELSE 

READ( TKNSTR (1 :2) , FMT=' ( 12) 1 )  INTEST 

ENOATE(REPNUM, OTENUM)  =  ENOATE(REPNUM, OTENUM)  +  INTEST 
ENO  IF 
GO  TO  LOOP 

C  STATE  20:  MM/DO  '/'  OF  END  OATE  RECOGNIZED. 

200  GO  TO  LOOP 


C  STATE 
210 

211 


C  STATE 

220 

C  STATE 
230 


C  STATE 
240 

C  STATE 
250 


251 


252 


C  STATE 
260 

C  STATE 
270 


271 


21:  YEAR  OF  ENO  DATE  RECOGNIZED. 

IF  ( ,HOT.LDATE( 'YY' ,TKNSTR) )  THEN 
WR I TE  (  L I  ST  FL , FMT *211) 

FORMAT ( 1  **- ERROR:  ILLEGAL  YEAR  IN  END  DATE-**' ) 
ERRORF  ■  .TRUE. 

ELSE 

READ(TKNSTR(1 :2) , FMT«‘ ( 12) 1 )  INTEST 
ENDATE<R£PNUM,DTENUM)  ■  ENOATECREPNUM.DTENUM)  ♦ 
UNTEST  •  10000) 

ENO  IF 
GO  TO  LOOP 

22:  DATE  LIST  FOR  'OATE'  BEING  PROCESSED. 

GO  TO  LOOP 

23:  ‘ALL1  MISSIONS  ARE  TO  BE  INCLUDED. 

MSSNSLREPNUM,  1)  «  'ALL' 

GO  TO  LOOP 

24:  'TIME1  RECOGNIZED. 

GO  TO  LOOP 

25:  START  TIME  RECOGNIZED. 

READ(TKNSTR(1 :8) , FMT»‘ ( 18) 1 ) INTEST 
IF  (.NOT.LTIME(INTEST))  THEN 
WRITEJL1STFL, FMT*251 ) 

FORMAT < '  **- ERROR:  ILLEGAL  START  TIME-**') 

ELSE  IF  (TIMENM.GE .MXTIME)  THEN 

urite(listfl,fmt»252) 

FORMAT ( 1  **-WARNING:  TOO  MANY  TIMES  SPECIFIED-*** ) 
ERRORF  *  .TRUE. 

ELSE 

TIMENM  *  TIMENM  ♦  1 
STTIMEfREPNUM, TIMENM)  ■  INTEST 
ENO  IF 
GO  TO  LOOP 

26:  BETWEEN  START  TIME  AND  END  TIME  RECOGNIZED. 

GO  TO  LOOP 

27:  ENO  TIME  RECOGNIZED. 

READ(TKNSTR(1 :8) , FMT»‘ < 18) 1 ) INTEST 
IF  (. NOT. LTIMEC INTEST))  THEN 
URITE(LISTFL, FMT*271 ) 

FORMAT ( 1  •*- ERROR:  ILLEGAL  END  TIME-**') 

ERRORF  *  .TRUE. 

ELSE 

EN TI ME (REPNUM, TIMENM)  *  INTEST 
END  IF 
GO  TO  LOOP 


C  STATE  28:  TIME  LIST  FOR  'TIME'  BEING  PROCESSED. 
280  GO  TO  LOOP 


C  STATE 
290 


C  STATE 
300 

C  STATE 
C 

310 


C  STATE 

320 

321 


322 


C  STATE 
330 

C  STATE 
340 


C  STATE 

350 

351 


29:  'ALL'  TIMES  ARE  TO  8E  INCLUDED 
STTIME(REPNUM,  1)  *  9999 
ENTIHE<REPNUM,  1)  *  9999 
50  TO  LOOP 

30:  'ACWTN1  RECOGNIZED. 

GO  TO  LOOP 

31:  'AIRCRAFT'  RECOGNIZED. 

THEREFORE  ALL  TAIL  NUMBERS  ARE  VALID 
TAILNM(REPNUM, 1)  ■  'ALL' 

GO  TO  LOOP 

32:  AIRCRAFT  TYPE  RECOGNIZED. 

IF  (TKNLEN.GT.LEN(ARCRFT(1,1)))  THEN 
WRITE(LISTFL,FMT*321) 

FORMAT ( '  **- ERROR:  AIRCRAFT  TYPE  TOO  MANY  CHARACTERS-**') 
ERRORF  *  .TRUE. 

ELSE  IF  (ACNUM.GE.MXPLNS)  THEN 
WRITE(L1STFL,FMT*322) 

FORMAT ( '  **-WARNING:  TOO  MANY  AIRCRAFT  TYPES  LISTED-**') 
ERRORF  *  .TRUE. 

ELSE 

ACNUM  «  ACNUM  *  1 

ARCRFT(REPNUM,ACNUM)  *  TKNSTRO :LEN(ARCRFT(1 , 1 ) ) ) 

ENO  IF 
GO  TO  LOOP 

33:  IDENTIFIER  LIST  FOR  AIRCRAFT  TYP*S  BEING  PROCESSED 
GO  TO  LOOP 

34:  AIRCRAFT  TYPE  RECOGNIZED. 

IF  (TKNLEN.GT . LEN(ARCRFT (1,1)))  THEN 
URITE(LISTFL,FMT=321) 

ELSE  IF  (ACNUM.GE.MXPLNS)  THEN 
WR I  TE( L I  ST  FL , FMT =322 ) 

ELSE 

ACNUM  *  ACNUM  ♦  1 

ARCRFTCREPNUM, ACNUM)  *  TKNSTRCl :LEN(ARCRFT( 1 , 1 ) ) ) 

ENO  IF 

CONTRL  *  .TRUE. 

GO  TO  LOOP 

35:  TAIL  NUMBER  'ACWTN'  RECOGNIZED. 

IF  (TKNLEN.GT. L£N(TAILNM<1,1)))  THEN 
WR I TE ( L 1  ST  FL , FMT =35 1 ) 

FORMATC  **- ERROR:  ILLEGAL  TAIL  NUMBER  SPECIFIED-**') 
ERRORF  =  .TRUE. 

ELSE 

TAILNM(REPNUM, ACNUM)  =  TKN$TR( 1 ;TKNLEN ) 

END  IF 
GO  TO  LOOP 


C  STATE  36:  IDENTIFIER  LIST  FOR  'ACWTN'  BEING  PROCESSED. 


360 


GO  TO  LOOP 


C  STATE 
370 


C  STATE 
380 


C  STATE 
390 


C  STATE 
400 


C  STATE 
C 

410 


C  STATE 
420 


C  STATE 
C 

430 


C  STATE 
440 


3572 


C  STATE 
C 

450 


37:  'ALL'  'ACyTN*  ARE  TO  BE  INCLUDED. 

ARCRFT(REPNUM,  1)  ■  'ALL' 

TAILNM(R£PNUM,  1)  *  'ALL' 

GO  TO  LOOP 

38:  'ALL1  AIRCRAFT  ARE  TO  BE  INCLUOED. 

ARCRFT (REPNUM,  1)  *  'ALL1 
GO  TO  LOOP 

39:  'STAT'  RECOGNIZED. 

STATFL  *  .TRUE. 

GO  TO  LOOP 

40:  'BOOMTRK'  RECOGNIZED. 

BOCMFL  -  .TRUE. 

GO  TO  LOOP 

41:  INTEGER  OR  REAL  FOUND  AFTER  1 BOOMTRK' 

CONVERT  THE  TOKEN  STRING  TO  A  REAL  NUMBER  AND  STORE 
READ(TKNSTR(1 ;12) , FMTa' (F1Q.Q)' )  BOOMVA 
GO  TO  LOOP 

42:  'MACHTRK1  RECOGNIZED. 

MACHFL  «  .TRUE. 

GO  TO  LOOP 

43:  INTEGER  OR  REAL  FOUND  AFTER  'MACHTRK' 

CONVERT  THE  TOKEN  STRING  TO  A  REAL  NUMBER  AND  STORE 
READ(TKNSTR ( 1 : 12) , FMT= ' ( FI 0 . 0) • )  MACHVA 
GO  TO  LOOP 

44:  'CONTOUR'  RECOGNIZED. 

CONTFL  «  .TRUE. 
iNTEST  *  0 

CONTREP  *  CONTREP  ♦  1 
IF  ( CONTREP. GT.MXREPS)  THEN 
URITE(LISTFL,3572) 

FORMATC**- WARNING:  TO  MANY  CONTOUR  SPECS.') 

ERRORF  ■  .TRUE. 

ENO  IF 
GO  TO  LOOP 

45:  INTEGER  OR  REAL  FOUND  AFTER  'CONTOUR  XXXX' 

CONVERT  THE  TOKEN  STRING  TO  A  REAL  NUMBER  AND  STORE 
INTEST  *  INTEST  ♦  1 
IF  (INTEST  .GT.  MXCONT)  THEN 

UR  I  TE( L I STFL ,  *)  '♦♦■WARNING:  TOO  MANY  CONTOUR  VALUES-**' 
ERRORF  =  .TRUE. 

ELSE 

REA0(TKNSTR(1 : 12), FMT=' (F10.0) ’ )  CONTVAt CONTREP, INTEST) 
END  IF 
GO  TO  LOOP 


C  STATE  46:  SCALE  LIST  FOR  ’CONTOUR'  BEING  PROCESSED 
460  GO  TO  LOOP 

C  STATE  47:  'TITLE'  RECOGNIZED 
470  CONTRL  =  .TRUE. 

COL  *  1 
GO  TO  LOOP 

C  STATE  48:  CONCATENATE  ALL  TITLE  PIECES  TOGETHER. 

480  IF  ( ( COL+TKNLEN ) . LE . ( LEN (T I TLE ) ) )  THEN 

T I TLE { COL : ( COL+TKNLEN • 1 ) )»TKNSTR( 1 : TKNLEN ) 

ENO  IF 

COL  ■  COL  ♦  TKNLEN  +  1 
CONTRL  »  .TRUE. 

GO  TO  LOOP 

C  STATE  49:  CONTOUR  TYPE  RECOGNIZED  AFTER  'CONTOUR' 

490  IF  (TKNSTRO  : TKNLEN)  .£Q.  'CSEL'  )  THEN 

CONTYP(CONTREP)  *  1 
TCSEL  «  .TRUE. 

ELSE  IF  (TKNSTR(1: TKNLEN ).EQ.  1 CLDN '  )  THEN 
CONTYP(CONTREP)  ■  2 

ELSE  IF  (TKNSTRO : TKNLEN) .EG.  'PKOP'  )  THEN 
CONTYP( CONTREP )  *  3 
ENO  IF 
GO  TO  LOOP 

C  STATE  50:  'WIDTH'  CARD  RECOGNIZED 
500  GO  TO  LOOP 

C  STATE  51:  INTEGER  OR  REAL  RECOGNIZED  AFTER  'WIDTH' 

510  READ(TKNSTR(1:8),FMT='(F6.2)')  WIDTH 

IF  ((WIDTH.L£.8).OR.(WIOTH.GE.48))  THEN 
C  WRITE(LISTFL,FMT='(A\)')  '++-WARNING:  ILLEGAL' 

WRITE(LISTFL,FNT»'(A)' )  '++-WARNING:  ILLEGAL' 
WRITE(LISTFL, FNT*' (A) 1 )  '  WIDTH,  DEFAULT  TO  30"' 
WIDTH  =  30.0 
ENO  IF 
GO  TO  LOOP 

C  STATE  52:  ','  RECOGNIZED  AFTER  'CONTOUR  XXXX’ 

520  GO  TO  LOOP 

C  STATE  54:  ' FFT '  RECOGNIZED. 

525  FFT  *  .TRUE. 

GO  TO  LOOP 

C  STATE  55:  'SIGNAT'  RECOGNIZED. 

527  SIGNAT  =  .TRUE. 

GO  TO  LOOP 

C  STATE  56:  'STATONLY'  RECOGNIZED. 

528  RAYTRC  *  .TRUE. 


ST AT a  »  .TRUE. 

GOTO  LOOP 

C  STATE  57:  'SCRCHPAO'  RECOGNIZED. 

535  SCRPAD  *  .TRUE. 

GOTO  LOOP 

C  STATE  58:  *08  OR  PSP  RECOGNIZED. 

537  IF  (TKNSTR(1:TKHLEH)  .£Q.  '08')  THEN 

SCRPSF  *  .FALSE. 

ELSE 

SCRPSF  *  .TRUE. 

END  IF 
GOTO  LOOP 

C  STATE  59:  'ALL  OR  NEW  RECONGNIZED. 

538  IF  (TKNSTRO :TKNLEN)  .EG.  'ALL')  THEN 

SCRALL  *  .TRUE. 

END  IF 
GOTO  LOOP 

C  STATE  53:  ACCEPT  STATE 

C  PRINT  OUT  A  TABLE  OF  THE  INFORMATION  STORED  DURING  THE  PARSE 

530  DO  600  TBLMUM  »  1,  REPNUM 

URITE(LISTFL,550)  TBLNUM,  REPNUM 
550  F0RMAT<1X//,3X, 'TABLE: ‘,2X, 12, •/', 12,/) 

WRITE(L1STFL,560) 

560  FORMAT(2X,91 ('*')) 

WRITE(LJSTFl,570) 

570  FORMAT (2X, • ! • ,4X, 'SITE' ,4X, • ! * ,5X, 'EXRECISE' ,5X, ' ! • ,6X, 

+  'DATE',7X, '! '  ,4X, 'TIME' ,5X, •! AIRCRAFT! ' ,3X, ' TAIL ' ,3X , 

♦  '!  #  !'/,2X,'!',2X, 'LOCATION', 2X,'(',7X, 'NAME', 7X, 

♦  ' !  [YYMMOO - YYMMD01  !  (HHMM-HHMM)  ! ' ,2X, 'TYPE' , 

♦  2X, ' ! ' ,2X, 'NUMBER ', 2X, '! ',5X, '! ’/,2X, ' ! ' ,89( ) 
COL  »  1 

C  PRNTROU: 

1550  LSTBUFF  *  '  ' 

LST8UFF( 1:1)  «  •!' 

LST8UFF(3: 12)  *  S1TES(TBLNUM,C0L) 

LST8UFF(14:14T  ■  '!  ' 

LSTBUFF(16:31)  «  MSSNS(TSLNUH,COL> 

LST8UFF(33:33)  »  •!' 

IF  <ST0ATE(TBLNUM,1).EQ.9999)  THEN 

IF  (C0L.E0.1)  LSTBUFF(35:37)  =  'ALL' 

ELSE  IF  ( ST0ATE< TBLNUM, COL). EG. 0)  THEN 
LSTBUFF(35:49)  *  '  • 

ELSE 

LST8UFF(35:35)  *  '[' 

WRITE (LSTBUFF (36:41 ), ' ( 16) ' )STDATE (TBLNUM, COL ) 
LST8UFF(42:42)  =  ' • ' 

WR I TE(LSTBUFF(43 : 48 ) , ' ( 16) 1 )ENDATE ( TBLNUM , COL ) 
LSTBUFF(49:49)  =  •] ' 

ENO  IF 

LSTBUFF(5i:51)  *  '! ' 


IF  ( STT I ME < TBLNUM, 1).EQ. 9999)  THEN 

IF  (C0L.E0.1)  LSTBUFF(53:55)  *  'ALL' 

ELSE  IF  ( STT I ME ( TBLNUM , COL ) . EQ . 0 )  THEN 
LST8UFF<53:63)  ■  1  ‘ 

ELSE 

LST8UFF(53:53)  *  '  C‘ 

WRITE(LSTBUFF(54:57) , 1 (14) 1 ) STT I ME (TBLNUM, COL) 
LSTBUFF(53:58)  * 

WRITE(LSTBUFF<59:62) , ' (14) 1 )ENT I ME (TBLNUM, COL) 
LSTBUFF(63:63)  *  *1 • 

END  IF 

LSTBUFF<65:65)  «  '!' 

LSTBUFF(67:72)  *  ARCR FT (TBLNUM, COL) 

LSTBUFF(74:74)  *  M‘ 

LSTBUFF(76:83)  ■  T A I LNM( TBLNUM, COL > 

LSTBUFF(85:85)  *  '!• 

WRITE<LSTBUFF(87:S9), •<I3)*>  COL 
LST8UFF(91 :91 )  «  '!• 

WRITE(LISTFL, FMT=‘ (2X,A91 ) 1 3LSTBUFF 

CHECK  IF  ANOTHER  ROW  SHOULD  BE  PRINTED. 

COL  *  COL  ♦  1 

IF  (SITESdBLNUM,COL).NE. '  1 .OR .MSSNS( TBLNUM, COD .NE . 1  1 
. OR . STDATE (  TBLNUM ,  COL  ) .  NE .  0 .  OR .  STT  I  ME  { TBLNUM ,  COL  ) 
.NE.Q.OR.ARCRFT(TBLNUM, COL) .NE. 1  •)  GOTO  PRNTROW 

URITE(LISTFL,580) 

FORMAT <2X,90( ' *' ) ) 

CONTINUE 

IF  ( ( FFT)  .AND.  (TCSED)  THEN 
DO  650  1*1,5 

IF  ((CONTYPd)  .EO.  2)  .OR.  (CONTYP(I)  .EQ.  3))  THEN 
WRITE  (L1STFL.3575) 

FORMAT ( '♦♦•WARNING  :  OVERPRESSURE  AND  CSEL  NO  LONGER 
RELATED  CONTOUR  ABORTED') 

CONTYP(I)  *  0 
DO  620  J  *  1,  20 
CONTVAd.J)  *  0.0 
CONTINUE 
END  IF 
CONTINUE 
IT  a  1 

DO  670  I  *  1,5 

IF  (CCONTYP(I)  .EQ.  1)  .AND.  (IT  .NE.  I))  THEN 
CONTYP(IT)  a  1 
CONTYP(I)  *  0 
DO  660  J  «  1,20 

C0NTVA( IT , J )  =  CONTVA( I , J ) 

CONTVAd  ,  J)  =  0 
CONTINUE 
IT  =  IT  ♦  1 
END  IF 
CONTINUE 


END  IF 
RETURN 

#S3»SX$33S33332<mS2ZS»32S3SS3S3=5S3Sa23S338S8SXS 

. »»>  END  PRSPACK  ««< 
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MOOULE  NAME:  SCHPACK 
MOOULE  TYPE:  PACKAGE 

OVERVIEW: 

THIS  PACKAGE  IS  USED  TO  PERFORM  THE  PROCESS  OF  SEARCHING 
THE  OATA  TABLES  CREATED  DURING  THE  PARSE  STAGE.  THIS  SEARCH 
IS  USED  TO  FIND  RECORDS  OF  SUBSONIC  ANO  SUPERSONIC  FLIGHT  DATA 
RECORDS  IN  THE  LIBRARY  FILE  BY  FINDING  THEIR  LOCATION  THROUGH 
THE  USE  OF  AN  1NOEX  FILE.  THIS  INDEX  FILE  IS  SIMILAR  TO  A  CARD 
CATALOG. 

INTEFACE: 

GETREC  (  PI,  P2r  P3  > 

PI  [INTEGER]  POINTER  TO  THE  STARTING  RECORD 
P2  [INTEGER]  TOTAL  OF  RECORDS  STARTING  AT  PI 
P3  [LOGICAL]  FLAG  SIGNALING  NO  MORE  RECORDS  LEFT 

INTERNAL  SUBROUTINES  l  FUNCTIONS 

FILBUFO  ;  READS  ON  RECORD  FROM  THE  INDEX  FILE  INTO  A  3UFFE 
STRMCHO  ;  RETURNS  TRUE  IF  A  STRING  MATCHES  WITH  TABLE  STR 
INTMCHO  ;  RETURNS  TRUE  IF  AN  I  NT.  MATCHES  WITH  TABLE  INTE 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  23 -OCT -85 

REVISIONS  : 


MOOULE  NAME:  SCHPACKNFILBUF 

MODULE  TYPE:  CHARACTER  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  READ  IN  ON  RECORO  FROM  T 
INOEX  FILE.  IF  THERE  ARE  NO  MORE  RECORDS  THEN  THE  FLAG  .ENOREC. 
SET  TRUE. 

INVOCATION: 

[X  =  ]  FIIBUF  (  PI,  P2,  P3,  PL  ) 

PI  ::=  [INTEGER]  CURRENT  RECORD  NUMBER 

P2  ::*  [INTEGER]  NUM8ER  OF  RECORDS  IN  INDEX  FILE 

P3  [INTEGER]  UNIT  NUMBER  CORRESPOND  I NG  TO  INOEX  FIL 


P4  ::=  [LOGICAL]  FLAG  SIGNALING  THE  END  OF  RECOROS 


VARIA8LE  DICTIONARY: 

ENDREC  ;  P4 
IOXFIL  ;  P3 
NUHREC  ;  P2 
RECNUH  ;  PI 

CALLER  HOOULES: 

[SUBROUTINE]  SCHPACKXGETREC 

CALLED  HOOULES: 


.NONE... 


PROGRAHHER:  8RUCE  8.  LACEY 
DATE  :  22 -OCT -85 

REVISIONS  : 

CHARACTER*^)  FUNCTION  F!LBUF( 

RECNUH,  NUHREC,  IDXFIL,  ENDREC) 

INTEGER  RECNUH,  NUHREC,  IOXFIL 
LOGICAL  ENDREC 

IF  (RECNUH. LE. NUHREC)  THEN 
RECNUH  =  RECNUH  ♦  1 

REAO( IDXFI L, FHTs1 (A) ' ,REC=RECNUH)  FILBUF 
ELSE 

ENDREC  =  .TRUE. 

END  IF 

RETURN 

END 


MOOULE  NAME:  SCHPACK\STRMCH 

MODULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  SEE  IF  A  STRING  PASSED 
IN  MATCHES  ANY  STRING  IN  THE  CURRENT  ROU  OF  A  TABLE  PASSED  IN. 
IF  'ALL'  IS  FGUNO  THEN  THE  SEARCH  IS  CONSIDERED  SUCCESSFUL. 

INVOCATION: 

CX  *  ]  STRMCH  (  PI,  P2,  P3,  P4,  P5  ) 

PI  ::*  [CHARACTER*?*)]  STRING  TO  SEARCH  FOR 

P2  ::»  [INTEGER]  REPETITION  BEING  TESTED 

P3  ::=  [CHARACTER*<*>  <P4,P5)]  TABLE  TO  SEACH  THROUGH 

P4  ::*  [INTEGER]  BOUND  FOR  THE  ROU  SIZE 

P5  ::*  [INTEGER]  BOUNO  FOR  THE  COLUMN  SIZE 

VARIABLE  DICTIONARY; 


COL 

;  CURRENT 

COLUMN  IN  THE  SEARCH  TABLE 

CURREP 

;  P2 

EXTLOP 

;  SYMBOL 

REPRESENTING  STATEMENT  LABEL  200 

MXCOL 

;  P5 

MXROW 

;  P4 

SRCFOR 

;  PI 

TABLE 

;  P3 

CALLER  MODULES: 

[SUBROUTINE]  SCHPACKXGETREC 
CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  8RUCE  B.  LACEY 
OATE  :  22-OCT-85 

REVISIONS  : 

LOGICAL  FUNCTION  STRMCH < 

SRCFOR,  CURREP,  TABLE,  MXROW,  MXCOL) 

INTEGER  CURREP,  MXROW,  MXCOL,  COL,  EXTLOP 
CHARACTER*?*)  SRCFOR,  TA8LE(MXROW, MXCOL) 

ASSIGN  200  TO  EXTLOP 


STRMCH  =  .FALSE. 


100 

C  EXTLOP: 
200 


DO  100  COL  *  1,  MX COL 

IF  (( TABLE  {  CURREP , COL ) . EQ .  'ALL'). OR. 

<  TABLE < CURREP , COL ). EO . SRCFOR  >)  THEN 
IF  (TABLE (CURREP, COL) .ME. 1  >)  THEM 
STRMCH  *  .TRUE. 

GO  TO  EXTLOP 
END  IF 
END  IF 
CONTINUE 


RETURN 


END 


MOOULE  NAME:  SCHPACKM NTMCH 

MODULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  TEST  IF  AN  INTEGER  PASSE 
IN  MATCHES  AN  INTEGER  IN  THE  CURRENT  ROW  OF  THE  TABLE  PASSED  IN. 
IF  9999  IS  FOUND  THEN  THE  TEST  IS  CONSIDERED  SUCCESSFUL. 

INVOCATION: 

K  =  ]  INTMCH  (  PI.  P2,  P3,  PA,  P5,  P6  ) 

PI  ::=  (INTEGER]  VALUE  TO  BE  TESTED 
P2  (INTEGER]  ROW  CURRENTLY  BEING  TESTED 
P3  [1NTEGER(P5,P6>]  TABLE  FOR  LOWER  BOUND 
PA  ::*  [1NTEGER(P5,P6)]  TABLE  FOR. UPPER  BOUND 
PS  ::»  [INTEGER]  LOWER  BOUND  FOR  P3  AND  PA 
P6  ::=  [INTEGER]  UPPER  BOUND  FOR  P3  AND  PA 

VARIABLE  DICTIONARY: 

COL  ;  CURRENT  COLUMN  IN  SEARCH  TABLES 
CURREP  ;  P2 
ETABLE  ;  P3 

EXTLOP  ;  SYMBOL  REPRESENTING  STATEMENT  LABEL  200 

MXCOL  ;  P6 

MXROW  ;  P5 

SRCFOR  ;  PI 

STABLE  ;  PA 

CALLER  MOOULES: 

[SUBROUTINE]  SCHPACKNGETREC 

CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22 -OCT -85 

REVISION  : 

LOGICAL  FUNCTION  INTMCH( 

SRCFOR,  CURREP,  STABLE,  ETABLE,  MXROW,  MXCOL) 

INTEGER  SRCFOR,  CURREP,  MXROW,  MXCOL,  EXTLOP 
INTEGER  COL,  LOOP 

INTEGER  ST ABLE (MXROW, MXCOL ) ,  ETABLE(MXROW, MXCOL) 


C  LOOP: 
100 


C  EXT LOP: 
200 


ASSIGN  100  TO  LOOP 
ASSIGN  200  TO  EXTLOP 

INTMCH  -  .FALSE. 

IF  ( STABLE ( CURREP , 1 ) .£0.9999)  THEN 
INTMCH  *  .TRUE. 

ELSE 

COL  «  1 

I F ( ( SRCFOR . GE . ST ABLE ( CURREP , COL)). AND. 
(SRCFOR . LE . ETABLE ( CURREP , COL )) )  THEN 
INTMCH  ■  .TRUE. 

GO  TO  EXTLOP 
ENO  IF 

COL  «  COL  ♦  1 

IF  (COL.LE.MXCOL)  GO  TO  LOOP 

ENO  IF 
RETURN 


ENO 


MODULE  NAME:  SCHPACKNGETREC 
MODULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  SERARCH  THE  INDEX  FILE  ACCORDING 
THE  USER  SPECIFICATIONS  STORED  DURING  THE  PARSE  STAGE.  WHEN  INVO 
THIS  SUBROUTINE  WILL  READ  RECORDS  FROM  THE  INDEX  FILE  UNTIL  A  MAT 
IS  FOUND.  WHEN  A  MATCH  IS  FOUND  THE  SUBROUTINE  WILL  RETURN  THE 
STARTING  RECORD  NUMBER  AND  THE  NUMBER  OF  RECORDS  XCURING  AFTER 
THE  STARTING  RECORD.  IF  A  MATCH  IS  NOT  FOUND  THEN  THE  END  OF  REC 
FLAG  .ENDREC.  IS  SET  TRUE. 


INVOCATION: 

[CALL]  GETREC  (  PI,  P2,  P3,  P4  ) 

PI  ::■  [INTEGER]  STARTING  RECORD  NUMBER 
P2  [INTEGER]  COUNT  OF  RECORDS  FOLLOWING  PI 

P3  [INTEGER]  COUNT  OF  SUPERSONIC  RECORDS 

P4  [LOGICAL]  FLAG  SIGNALING  THE  END  OF  RECORDS 

VARIABLE  DICTIONARY: 


ARCRFT 

CURREC 

ENDATE 

ENDREC 

ENTIME 

IDXFIL 

INTDAT 

LOOP 

MSSNS 

MXDATE 

MXMSSN 

MXPLNS 

MXREPS 

MXSITE 

MXTIME 

NUMREC 

NUMREP 

RECBUF 

RECTOT 

SITES 

STREC 

STTIME 

TAILNM 

TBLIDX 

TIME1 

TIME2 


TABLE  CONTAINING  AIRCRAFT  TYPES 

THE  CURRENT  RECORD  NUMBER  FROM  FILE  'INDEX' 

TABLE  CONTAINING  THE  END  DATES 
P3 

TABLE  CONTAINING  THE  END  TIMES 

UNIT  NUMBER  FOR  THE  INDEX  FILE 

INTEGER  REPRESENTING  YYMMOD  DATE 

SYMBOL  REPRESENTING  STATEMENT  LABEL  1 

TABLE  CONTAINING  THE  MISSION/EXERCISE  NAMES 

MAXIMUM  NUMBER  OF  DATE  ALLOWED 

MAXIMUM  NUMBER  OF  MISSION  ALLOWED 

MAXIMUM  NUMBER  OF  AIRCRAFT  ALLOWED 

MAXIMUM  NUMBER  OF  REPETITIONS  OF  SITE  CARDS  ALLOWS 

MAXIMUM  NUMBER  OF  SITES  LOCATIONS  ALLOWED 

MAXIMUM  NUMBER  OF  START/END  TIMES  ALLOWED 

NUMBER  OF  RECOROS  IN  THE  INDEX  FILE 

NUMBER  OF  REPETITIONS  STORED  DURING  PARSE 

BUFFER  TO  HOLD  ONE  RECORD  FROM  FILE  'INDEX' 

P2 

TABLE  CONTAINING  THE  SITE  LOCATIONS 
PI 

TABLE  CONTAINING  THE  STARTING  TIMES 
TABLE  CONTAINING  THE  AIRCRAFT  TAIL  NUMBERS 
CURRENT  REPETITION  BEING  COMPARED 
STARTING  TIME  FROM  RECORD  IN  'INDEX' 

ENDING  TIME  FROM  RECORD  IN  'INDEX' 


CALLER  MCOULES 


MAIN  DRIVER  ROUTINE 
CALLED  MCOULES: 

C SUBROUTINE  FUNCTION]  SCHPACK\F I LBUF ( ) 

[SUBROUTINE  FUNCTION]  SCHPACK\SCHMCH( > 

[SUBROUTINE  FUNCTION]  SCHPACKMNTMCHO 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22-OCT-S5 

REVISIONS  : 

SUBROUTINE  GETRECCSTREC,  RECTOT,  SUPREC,  ENOREC,  II) 

EXTERNAL  STRMCH,  INTMCH,  FILBUF 

PARAMETER (MXOATE* 10,  MXMSSN*10,  MXPLNS=10, 

MXR£PS*5. ,  MXSITE*20,  MXTIME*10> 

COMMON  /CHRTABS/  ARCRFT,  MSSNS,  SITES,  TAILNM 

COMMON  /INTTA8S/  ENOATE,  ENTIME,  STDATE,  STTIME,  NUMREP 

INTEGER  ENOATECMXREPS , MXD ATE ) 

INTEGER  ENT I ME (MXREPS , MXT I ME ) 

INTEGER  STD ATE (MXREPS , MXO ATE ) 

INTEGER  STTIME(MXREPS,MXTIME) 

INTEGER  NUMREP,  STREC,  RECTOT,  CURREC,  INTDAT,  LOOP 
INTEGER  TIME1 ,  TIME2,  IDXFIL,  NUMREC,  TBLIDX,  SUPREC 

CHARACTER'S  ARCRFT (MXREPS , MXPLNS ) 

CHARACTER'1 6  MSSNS (MXREPS , MXMSSN ) 

CHARACTERS 0  SITES(MXREPS.MXSITE) 

CHARACTER'S  TA I LNM(MXREPS , MXPLNS ) 

CHARACTER*98  FILBUF,  RECSUF 

LOGICAL  ENOREC,  STRMCH,  INTMCH 

SAVE  CURREC 

DATA  IDXFIL  /I/ 

DATA  CURREC  /0/ 

ASSIGN  1  TO  LOOP 


IF  (CURREC. L£. 1 )  THEN 

READ  THE  HEADER  RECORD  TO  GET  THE  NUMBER  OF  RECORDS. 
CURREC  =  CURREC  +  1 

READ( IDXFIL, FMT= 1 (16)' ,REC=CURREC)  NUMREC 
ENOREC  *  .FALSE. 

END  IF 


TBL1DX  «  0 


C--  GET  THE  STARTING  RECORD 

REC8UF  •  F I LBUF ( CURREC , NUMREC , IDXF I L , ENOREC) 

C  COOP: 

1  IF  ( ENOREC. EQV.. TRUE.)  RETURN 

TBLIDX  *  TBLIDX  ♦  1 
IF  (TBLIDX. GT.NUMREP)  THEN 
C--  READ  IN  ANOTHER  RECORD  FOR  TESTING 

RECBUF  *  F I LBUF { CURREC , NUMREC, I DXF I L , ENDREC) 

TBLIDX  *  1 
END  IF 

CHECK  IF  SITE  LOCATIONS  MATCH 

IF  (STRMCH(REC8UF(27:36>, TBLIDX, SITES, MXREPS, MXSITE) 
.EOV..TRUE.)  THEN 
CHECK  IF  THE  MISSION  NAMES  MATCH 

IF  (STRMCH(REC8UF(1 : 16), TBLIDX, MSSNS, MXREPS, MXMSSN) 
.EQV.. TRUE.)  THEN 
C-  CHECK  IF  THE  OATE  INTERVALS  CORRESPOND. 

c-  FIRST  CONVERT  THE  DATE  TO  YYMMOO  INTEGER 

REAO ( REC8UF ( 1 7 : 18 } , f MT*  <  < 1 2 ) ' )  I NTD AT 

INTO  AT  «  I  NTD  AT  •  100 

REAO (RECBUF (20: 21 ) , FMT*1 (12) 1 )  I 

INTDAT  *  INTOAT  ♦  I 

READ (RECBUF (23: 24 ) , FMT*1 (12) 1 )  I 

INTDAT  =  INTDAT  ♦  (I  *  10000) 

I F  ( 1 NTMCH( I NTD AT , TBL IDX , STDATE , ENO ATE , MXREPS , MXDATE ) 
+  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  TIME  INTERVALS  CORRESPOND. 

READ(REC8UF(37:40) ,FMT=‘ ( 14) 1 )  TIME1 
READ (RECBUF (45: 48), FMT*1 ( 14) • )  TIME2 
IF  ((INTMCH(TIME1, TBLIDX, STTIME.ENTIME, 

MXREPS, MXTIME). EQV.. TRUE.). OR. 

(INTMCH(T1ME2, TBLIDX, STTIME,ENTIME, 

MXREPS, MXTIME). EQV.. TRUE.))  THEN 
CHECK  IF  AIRCRAFT  TYPES  MATCH. 

IF  (STRMCH (RECBUF (55: 60) ,TBLIDX,ARCRFT, 

MXREPS, MXPLNS). EQV.. TRUE.)  THEN 
CHECK  IF  THE  AIRCRAFT  TAIL  NUMBERS  MATCH 

IF  (STRMCH (RECBUF (61 :68) , TBLIDX , TAI LNM, 
MXREPS, MXPLNS). EQV. .TRUE.)  THEN 
C-  UE  HAVE  A  SUCESSFUL  MATCH 

READ(R£CBUF(69:78), FMT* 1 (1 10) 1 )  STREC 
REA0(REC8UF(79:88) , FMT - 1 (110) 1 )  RECTOT 
REAO ( RECBUF (89: 98 ) , FMT= 1 (110) 1 )  SUPREC 


11  *  CURREC 
RETURN 
ELSE 

SO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
END  IF 
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»»»»  ENO  SCHPACK  <«« 


MODULE  NAME:  SCHPACXNGETOMC 
MOOULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  SERARCH  THE  INDEX  FILE  ACCORDING 
THE  USER  SPECIFICATIONS  STORED  DURING  THE  PARSE  STAGE.  WHEN  INVO 
THIS  SUBROUTINE  WILL  READ  RECORDS  FROM  THE  INDEX  FILE  UNTIL  A  MAT 
IS  FOUNO.  WHEN  A  MATCH  IS  FOUNO  THE  SUBROUTINE  WILL  RETURN  THE 
STARTING  RECORD  NUMBER  ANO  THE  NUMBER  OF  RECORDS  OCCURING  AFTER 
THE  STARTING  RECORD.  IF  A  MATCH  IS  NOT  FOUND  THEN  THE  END  OF  REC 
FLAG  .ENDREC.  IS  SET  TRUE. 

INVOCATION: 

[CALLI  GETINX  (  PI,  P2,  P3,  P4  ) 

PI  [INTEGER]  STARTING  RECORD  NUMBER 

P2  ::«  [INTEGER]  COUNT  OF  RECORDS  FOLLOWING  PI 
P3  [INTEGER]  COUNT  OF  SUPERSONIC  RECORDS 

P4  ::*  [LOGICAL]  FLAG  SIGNALING  THE  END  OF  RECORDS 


VARIABLE  DICTIONARY: 


ARCRFT 

CURREC 

ENOATE 

ENDREC 

ENT  I ME 

IDXFIL 

INTDAT 

LOOP 

MSSNS 

MXDATE 

MXMSSN 

MXPLNS 

MXREPS 

MXSITE 

MXTIME 

NOPREC 

NUMREC 

NUMREP 

OPR 

RECBUF 

RECTOT 

SITES 

STREC 

STTIME 

SUPREC 

TAILNM 


TABLE  CONTAINING  AIRCRAFT  TYPES 

THE  CURRENT  RECORD  NUMBER  FROM  FILE  'INDEX' 

TABLE  CONTAINING  THE  END  DATES 
P3 

TABLE  CONTAINING  THE  END  TIMES 

UNIT  NUMBER  FOR  THE  INDEX  FILE 

INTEGER  REPRESENTING  YYMMDD  DATE 

SYM80L  REPRESENTING  STATEMENT  LABEL  1 

TABLE  CONTAINING  THE  MISSION/EXERCISE  NAMES 

MAXIMUM  NUMBER  OF  DATE  ALLOWED 

MAXIMUM  NUMBER  OF  MISSION  ALLOWED 

MAXIMUM  NUMBER  OF  AIRCRAFT  ALLOWED 

MAXIMUM  NUMBER  OF  REPETITIONS  OF  SITE  CARDS  ALLOWE 

MAXIMUM  NUMBER  OF  SITES  LOCATIONS  ALLOWED 

MAXIMUM  NUMBER  OF  START/END  TIMES  ALLOWED 

NUMBER  OF  OVERPRESSURE  RECORDS. 

NUM8ER  OF  RECORDS  IN  THE  INDEX  FILE 
NUMBER  OF  REPETITIONS  STORED  DURING  PARSE 
FLAG  .TRUE.  IF  THE  TRACK  CONTAINS  OVERPRESSURE  REC 
8UFFER  TO  HOLD  ONE  RECORD  FROM  FILE  'INDEX' 

P2 

TABLE  CONTAINING  THE  SITE  LOCATIONS 
PI 

TABLE  CONTAINING  THE  STARTING  TIMES 
STARTING  OVERPRESSURE  RECORD. 

TABLE  CONTAINING  THE  AIRCRAFT  TAIL  NUMBERS 


TBL1DX  ;  CURRENT  REPETITION  BEING  COMPARED 
TIME1  ;  STARTING  TIME  FROM  RECORD  IN  'INDEX' 
TIME2  ;  ENDING  TIME  FROM  RECORD  IN  'INDEX' 

CALLER  MODULES: 

MAIN  DRIVER  ROUTINE 


CALLED  MCOULES: 

[SUBROUTINE  FUNCTION]  SCHPACK\FIL8UFO 
[SUBROUTINE  FUNCTION]  SCHPACK\SCHMCN(> 
[SUBROUTINE  FUNCTION]  SCHPACK\INTMCH( ) 


PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22 -OCT -85 

REVISIONS  : 


SUBROUTINE  GETINX(STREC,  RECTOT,  SUPREC,  ENDREC,  II,  NOPREC, 
OPR) 


EXTERNAL  STRMCH,  INTMCH,  FILBUF 

PARAMETER (MXDATE'1 0 ,  MXMSSN»10,  MXPLNS-10, 

♦  MXREPS«5  ,  MXSITE«20,  MXTIME*10) 

COMMON  /CHRTABS/  ARCRFT,  MSSNS,  SITES,  TAILNM 

COMMON  /INTTABS/  ENOATE,  ENTIME,  STDATE ,  STTIME,  NUMREP 

INTEGER  ENDATE(MXREPS.MXDATE) 

INTEGER  ENTIME(MXREPS,MXTIME) 

INTEGER  STDATE (MXREPS, MXDATE ) 

INTEGER  STT IME (MXREPS , MXT I  ME  ) 

INTEGER  NUMREP,  STREC,  RECTOT,  CURREC,  INTDAT,  LOOP 
INTEGER  TIME1 ,  TIME2,  IDXFIL,  NUMREC,  TBLIDX,  SUPREC 

CHARACTER*6  ARCRFT (MXREPS, MXPLNS) 

CHARACTER*16  MSSNS(MXREPS.MXMSSN) 

CHARACTER'10  S l TES(MXREPS , MXS I TE ) 

CHARACTER'S  TA I LNM(MXREPS , MXPLNS ) 

CHARACTER'110  FILBUF,  RECSUF 

LOGICAL  ENDREC,  STRMCH,  INTMCH,  OPR 

SAVE  CURREC 


DATA  CURREC  /0/ 
DATA  IDXFIL  /51/ 
ASSIGN  1  TO  LOOP 


1 


IF  (CURREC. LE.1)  THEN 

READ  THE  HEADER  RECORD  TO  GET  THE  NUM8ER  OF  RECORDS. 
CURREC  *  CURREC  ♦  1 


READ ( l DXF I L , FMT« ' ( I 6 ) ' , REC*CURREC )  NUMREC 
ENOREC  *  .FALSE. 

NUMREC  «  2 
NUMREC  *  NUMREC  •  1 
EMC  IF 

TBLIDX  *  0 

C- *  GET  THE  STARTING  RECORD 

REC8UF  »  F I LBUF(CURREC, NUMREC,  IDXF1L .ENOREC) 

C  LOOP: 

1  IF  ( ENOREC. EQV.. TRUE.)  RETURN 

TBLIDX  «  T8L1DX  ♦  1 
IF  (TBLIDX. GT.NUMREP)  THEN 
C- -  READ  IN  ANOTHER  RECORD  FOR  TESTING 

RECBUF  *  F I LBUF ( CURREC , NUMREC , IDXFIL, ENOREC) 

TBLIDX  *  1 
END  IF 

C--  CHECK  IF  SITE  LOCATIONS  MATCH 

IF  (STRMCH(RECBUF(27:36>, TBLIDX, SITES, MXREPS, MXSITE) 

♦  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  MISSION  NAMES  MATCH 

I F  <  STRMCHt  RECBUF ( 1 : 16) , T8L IDX , MSSNS , MXREPS , MXMSSN ) 

♦  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  DATE  INTERVALS  CORRESPOND. 

C-  FIRST  CONVERT  THE  DATE  TO  YYMMDD  INTEGER 

READ ( RECBUF ( 17: 18) , FMT= 1 ( 12) 1 )  INTDAT 
INTDAT  *  INTDAT  *  100 
READCRECBUFYEO^D.FMTs'C^)')  I 
INTOAT  ■  INTDAT  ♦  I 
READ (RECBUF (23: 24 ) , FMT*‘ ( 12) 1 )  I 
INTDAT  =  INTDAT  ♦  (I  *  10000) 

I F  ( I NTMCH( I NTDAT .TBLIDX, STDATE , ENDATE , MXREPS , MXD ATE ) 

♦  .EQV.. TRUE.)  THEN 

C*  CHECK  IF  THE  TIME  INTERVALS  CORRESPOND. 

READ(REC8UF(37:40),FMT*'(I4)' )  TIME1 
READ (RECBUF (45: 48) , FMT=' ( 14) 1 )  TIME2 
IF  ( ( 1 NTNCH( T I ME 1 , TBL I DX , STT I ME , ENT  I ME , 

MXREPS ,MXT I ME) .EQV. .TRUE. ) .OR . 
(INTMCH(TIME2,TBLIDX,STTIME,ENT1ME, 

MXREPS, MXTIME). EQV. .TRUE.))  THEN 
CHECK  IF  AIRCRAFT  TYPES  MATCH. 

IF  (STRMCH( RECBUF (55 :60) , TBL I DX , ARCRFT , 

MXREPS, MXPLNS).EOV. .TRUE. )  THEN 
C-  CHECK  IF  THE  AIRCRAFT  TAIL  NUMBERS  MATCH 


IF  <STRMCH(RECBUF(61:63),T8LIDX,TAILNM, 
MXR£PS,MXPLNS) .EQV. .TRUE. )  THEN 
WE  HAVE  A  SUCESSFUL  MATCH 
REA0(REC8UF(69: 78) , FMT* ' < 1 10) • )  STREC 
READ(REC3UF( 79:88), FMT* *(110)')  RECTOT 
REA0(REC8UF<89:98) ,  FMT*'  ( 110)')  SUPREC 
READ(REC8UF(99: 108) , FMT*' (110)')  NOPREC 
REAO(REC8UF<109: 109), FMT*' (11 ) ' )  OPR 
II  *  CURREC 
RETURN 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 


END 


c 
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c 

c 

C  SUBROUTINE:  RTRACE 
C  PROGRAMMER:  PHILIP  J.  OAT 

C  XONTECH  INC. 

C  B8N  LABORATORIES 

C  DATE:  OCTOBER  22,  1986 

C 

C  PURPOSE:  INITIAL  DRIVER  FOR  THE  TRAPS  ROUTINES.  RTRACE  CALLS 
C  THE  ROUTINES  8REAKS  THE  FLIGHT  TRACK  UP  INTO  SEGMENTS, 

C  CREATE  THE  SPLINES,  DO  MANEUVER  SCREENING  AND  PHI  ANGLE 

C  SELECTION,  AND  DO  THE  RAY  TRACING.  THE  FLIGHT  TRACK 

C  INFORMATION  IS  CONVERTED  FROM  FEET  TO  METERS  BEFORE  IT  I 

C  PROCESSED. 

C 

C 

C 

SUBROUTINE  RTRACE 

COMMON  /FLIGHT/NFP,FT1HE,FX,FY,F2,VX,VY,V2,FMACH,CA 
DIMENSION  FT1ME< 1156), FX< 1156), FY(1 156), FZC1 156) 

DIMENSION  VX( 1 156), VY< 1 156), V2( 1 156), FMACH(1 156), CA( 1156) 

C 

COMMON  /SPLIN£/NSP,S(100,3),A(100,3),B(100,3),C(100,3),D(100,3) 
REAL  S,A,B,C,D 

INTEGER  NSP 
C 

COMMON  /RAYLIM/  NLIMS,BEG(2),ENO<2) 

C 

COMMON  /PRINTS/  TITLE(30) , TINL5L 
CHARACTER**.  TITLE 
CHARACTER'S  TIMLBL 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM 
C 

COMMON  /ACIDNT /  IDENT 
CHARACTER'S  IDENT 

COMMON  /AGUE I G/  ACUT.ACL 
C 

COMMON  /UNI:'/  WTUNI T , HTUNI T 
CHARACTER'S  w TUN  IT ,HTUN IT 
C 

COMMON  /RYCTRL/NORAYS.STNO.UL.UR.LL.LR.RRTRAY.TIMBEG.DELTIM.NTIMS, 
♦OHIBEG, DELPHI ,NPH!S 

LOGICAL  NORAYS, STND , UL , UR , LL , LR , PRTRAY , LOGI C(2 , 2 ) 

EQUIVALENCE  < LOGI C( 1 , 1 ) ,UL ) 

REAL  PHIB(8),DPHI(8), SGN(2) 

INTEGER  MDEX(2,2) 


COMMON  /RAYN I T/  KGMH , NOCRVS , NUCRVS , I UPOWN , TO , PH ! 0 , XO , YO , 20 , 
+P10,P20,P30, OMEGA, DELTAO, PI FO,P2FO,P3FO,OMEGAF,XTO,YTO,ZTO, 

♦P1TO, P2T0 ,P3T0 , OMEGAT , XSO , YSO , 2S0 , P3S0 , RHOO , PCONST , NAGES , AGES(20) 
INTEGER  KGMH, NOCRVS, NUCRVS, IUPOUN 
LOGICAL  BETVEN 
C 

COMMON  /GROUND/  GLAYER , 2GRND , CGRNO ,UGRND , VGRND , REFLFC 
INTEGER  GLAYER 
C 

COMMON  /CAUSTC/  NUMC,TRACE,CT(360),CPHI(360),CXYZ(360,3) 

REAL  CXYZ 

LOGICAL  TRACE 
C 

COMMON  /RPOSN/  NPTR , CPOSN , RT( 200) , RXYZ( 200, 3) , RAGE ( 200 ) , 

♦  RPF ACT C  2000 , RVL I  FT , REMEM 

REAL  RT , RXY2 , RAGE , RPFACT , RVL I  FT 

INTEGER  NPTR, CPOSN 
LOGICAL  REMEM 
C 

COMMON  /INOEXR/  INOREC 
C 

COMMON  /STSPLN/  ISTT 
INTEGER  ISTT 

C 

REAL  V< 1 00,3) ,0 ISP< 1 00,3), CONV, T IME,T( 100), ANG(360),OP(360) 

REAL  CLANG 

INTEGER  NSEG , START< 1 00 ) , END0( 100) , N , Cl NOFL , SSR , SER 

LOGICAL  FLAG, RCBLG, STRT , SCRFLG.CFLAG, CAUSTC, ST ATT, FOUND 

CHARACTER  BUFFV»1 28, BUFF2«1 28 

DATA  CONV/ .3048/ , TMAX/2.2/ 

DATA  IN0F1L/1/,CIN0FL/51/ 

IF  (NFP.LE.O)  RETURN 
REWIND  8 

CALL  FFUNCC 10ENT , FOUND ) 

IF  (.NOT. FOUND)  RETURN 
C 

C-  CHECK  TO  SEE  IF  THE  FLIGHT  HAS  SEEN  PROCESSED 
C 

REAO ( I  NO F I L , 5000 , REC* I NOREC )  BUFFI 
READ <  C I  NO F L , '(110) ■ ,REC»1 ,ERR=8001 )  KREC 
K  *  1 

8000  CONTINUE 

READ( CINOFL , 5001 , REC=K , ERR =8001 )  8UFFZ 
IF  (BUFFI ( 1 :68  ) . EQ . 3UFF2( 1 : 68) )  THEN 
RETURN 
END  I  F 
K  =  K  ♦  1 

IF  (K.GT.KREC)  GOTO  8001 
GOTO  8000 


8001  CONTINUE 


REFLFC  =  1.0 
HTUNIT  S  'FT' 

UTUNIT  *  'KG' 

TIMLBL  =  'SSSSSS' 

C 

C-  GET  THE  FLIGHT  SEGMENTS 
C 

CALL  GETSEGC  FT I ME , FMACH , CA , F2 , NFP , START , ENDO , NSEG ) 
C 

C-  CONVERT  EACH  TRACK  INTO  METRIC  UNITS  « 

C 

00  50  J  *  1 ,NFP 
VX!J)  =  VX(J)*CONV 
VY( J )  s  VY(J)*CONV 
VZ(J)  =  VZCJ)*CONV 
FX(J)  =  FX(J)*CONV 
FY(  J)  *  FY( J )*CONV 
FZ(J)  *  FZ( J )*CONV 
50  CONTINUE 

STRT  *  .TRUE. 

CAUSTC  =  .FALSE. 

DO  100  I  *  1 ,  NSEG 
L  *  1 
C 

C-  CALCULATE  A  CUBIC  SPLINE  ABOUT  THE  VELOCITY  VECTORS 
C 

I  STY  =  STAfiT( 1) 

DO  110  J  =  START < I ) ,ENOO( I ) 

V(L ,  1 )  =  VX(J) 

V(L,2)  *  VY(J) 

V(L,3)  =  VZ(J) 

DISP(L, 1 )  =  FX< J) 

DtSP(L,2)  =  FY(J) 

DISP(L,3)  *  FZ(J) 

T(L)  =  FT  I ME <  J  > 

L  =  L  ♦  1 
110  CONTINUE 

NSP  =  ENDO(I)  •  START! I)  +  1 

IF  (NSP.LE.2)  GOTO  100 

CALL  SPLINE!T,V,NSP, 100, S , A , B , C,D > 

00  13  114=  1,  NSP 
13  CONTINUE 

CALL  LSOUAR(T) 


00  14,  114  =  1 , NSP 


14  CONTINUE 
J  *  1 

FLAG  *  .TRUE. 

120  CONTINUE 
C 

C-  STEP  THROUGH  SEGMENT  AT  EACH  TRACK  POINT. 

C-  IF  THERE  IS  A  GAP  OF  2.2  SECONDS  OR  MORE  THEN  INTERPOLATE 
C-  AT  A  TIME  HALF  WAY  BETWEEN  POINTS. 

C 

IF  (J.GT.1)  THEN 

IF  <(T(J)  -  T(J-1)).GT.THAX. AND. FLAG)  THEN 
TO  *  T(J-1)  ♦  (T<J)  •  T< J- 1 ))/2.0 
FUG  «  .FALSE. 

NOOE  ■  J  ■  1 
ELSE 

TO  »  T(J) 

FLAG  *  .TRUE. 

NOOE  a  J 
ENOIF 
ELSE 

TO  *  TfJ) 

FLAG  *  .TRUE. 

NOOE  a  j 
END  IF 

NOOEC  «  NOOE  ♦  START ( I )  -  1 
C 

C-  CALCULATE  AIRCRAFT  MOVEMENT  PARAMETERS  AND  LIMITING  ANGLES 
C 

MUMC  =  0 

KATTER  =  0 
KATTSR  »  0 

CALL  TACMOV(T0, NOOE, NOOEC,. TRUE.) 

IF  (NOOE.LE.O)  GOTO  126 

CALL  FILIMS(*126) 

C 

C-  DO  MANEUVER  STREGNTH  SCREENING 
C 

CALL  SCREENING, NANG, ZGRND) 

C 

C  TRACE  RAYS  AT  APPROPRIATE  ANGLES 
C 

TRACE  a  .FALSE. 

SCRFLG  *  .TRUE. 

STATT  a  .TRUE. 

KATTSR  a  0 
KATTER  =  0 

DO  125  K  =  1.NANG 
REWINO  9 

WRITE (9,*)  IDENT 


NPTR  *  0 
OPOO  *  0.0 
PH  10  »  ANG(K) 

CALL  RAYORG(*125) 

CALL  RAYTRK(. FALSE., RC8LG.CFLAG, *124) 

DO  6543  III  =  1.NPTR 
6543  CONTINUE 

C  CALL  RDSPCL 

CALL  SIGNUR(OPOO) 

CALL  SAVRAY 

CALL  $TOR£( 1 1 , STRT, .FALSE ., . FALSE . , 1REC) 

IF  (ST ATT)  THEN 
KATTSR  *  IREC 
SSR  •  IREC 
STATT  *  .FALSE. 

ELSE 

KATTER  *  IREC 
END  IF 

STRT  *  .FALSE. 

124  IF  (CFLAG)  THEN 

CAUSTC  *  .TRUE. 

END  IF 

125  CONTINUE 

126  CONTINUE 
C 

C-  GO  INTO  FOCUS  ORIVER 
C 

IF  ((NUMC.GT.O)  .AND.  (J  .GT.  1))  THEN 
TRACE  *  .TRUE. 

REWIND  12 
WRITE02,*)  '  • 

REWIND  12 

CALL  FOCMAP(TO , NOOE , NOOEC , ANG , NANG , RRCURV , CAUSTC ) 

CALL  RBRAYS 
END  IF 
C 

C-  SIDELINE  ATTENUATION  TO  80  08 
C 

IF  ( (KATTER -KATTSR)  .GT.  2)  THEN 
CALL  SIDATTOCATTSR , KATTER , ANG, NANG, SSR ) 

END  IF 

J  *  J  +  1 

IF  (J.LE.NSP)  GOTO  120 

100  CONTINUE 
C 

C-  ENTIRE  TRACK  IS  PROCESSED.  CLOSE  THE  SECTION  IN  THE  OUTPUT  FILES 
C 

CALL  STORE(0, .FALSE. , .TRUE. .CAUSTC, IREC) 


C 


C-  CONVERT  EACH  TRACK  BACK  FROM  METRIC  UNITS 
C 

00  55  J  *  1 ,NFP 
VX(J)  *  VX(J)/CONV 
VX(J)  *  VY( JJ/CONV 
VX(J)  *  VZ(J)/CONV 
FX(J)  «  FX( J5/C0NV 
FXCJ)  *  FY(J)/CONV 
FX( J)  ■  FZCJ)/CONV 

55  CONTINUE 

RETURN 

5000  FORMAT (A90) 

5001  FORMAT  <A 1 10) 

6000  FORMAT ('0NUM8ER  OF  ANGLES  »',14> 

6001  FORMAT (3X,I4,3X,F10.4,3X,F10.4) 

6002  FORMAT (5X.4F10.4) 

6005  FORMAT (■ O', ///,5X, '**•**•**  RAY  RECURVES  BELOW  THE  GROUND 

+  i ******** *,///) 

ENO 


C:==xs3=:=33sssssxsssssssss:3ss3s:sssr:ss:sssss3sa:s=3ssss3>sssss33xa3ss 

c 

C  SUBROUTINE:  SPLINE 

C  PROGRAMMER:  CURTIS  F.  GERALD 

C  MOO  I F I ED  8T:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  0CT08ER  20.  1986 

C 
C 

C  THIS  ROUTINE  COMPUTES  THE  MATRIX  FOR  FINDING  THE  COEFFICIENTS 
C  OF  A  CUBIC  SPLINE  THROUGH  A  SET  OF  DATA. 

C  THE  SYSTEM  IS  THEN  SOLVED  TO  OBTAIN  THE  SECOND  DERIVATIVE  VALUES. 

C  USING  THE  SECOND  DERIVATIVES  THE  SPLINE  COEFFICIENTS  ARE  CALCULATED. 
C 

C  PARAMETERS: 

C  THE  SECONO  DIMENSION  OF  THE  ARRAYS  CORRESPOND 

C  TO  X,  Y,  AND  2  DIRECTIONS. 

C  INPUT:  TYPE 


c 

T(SIZE,3) 

R 

:  ARRAY  OF  TIME  VALUES 

c 

V(SIZE,3) 

R 

:  ARRAY  OF  VELOCITY  VALUES 

c 

N 

I 

NUMBER  OF  POINTS 

L 

c 

OUTPUT: 

c 

SO0Q,3) 

R 

ARRAY  OF  SECOND  DERIVATIVES 

c 

AOOO,3) 

R 

SPLINE  COEFFICIENT 

c 

S <100,3) 

ft 

SPUME  COEFFICIENT 

c 

CC100.3) 

R 

SPLINE  COEFFICIENT 

c 

D<100,3) 

R 

SPLINE  COEFFICIENT 

c 

VARAIBLES: 

c 

H(N,4,3) 

R 

AUGMENTED  MATRIX  OF  COEFFICIENTS  A 

c 

R.H.S.  FOR  FINDING  S 

c 

0T1 

R 

DELTA  TIME 

c 

DT2 

R 

DELTA  TIME 

c 

DT 

R 

DELTA  TIME 

c 

DV1 

R 

DELTA  VELOCITY 

c 

DV2 

R 

DELTA  VELOCITY 

c 

NM1 

I 

N  MINUS  ONE 

c 

c 

NM2 

I 

N  MINUS  TWO 

c 

SUBROUTINE  SPLINE  (T, 

V,  N, 

SIZE,  S,  A,  B,  C,  D) 

INTEGER  SIZE 

REAL  T(SIZE),  V(SIZE,3),S(SIZE,3),ACSIZE,3),B(SIZE,3) 
REAL  CCSIZE,3),D(SIZE,3) 

REAL  0T1,DT2,DV1,DV2,  M(1000,A,3) 

INTEGER  NM1.NM2 
C 

C  COMPUTE  FOR  THE  N-2  ROWS 


MM2  *  M  •  2 
NM1  ■  N  •  1 

DO  1000  K  *  1,3 

DTI  a  TC2)  •  TCI > 

0V1  a  <V(2,IO  •  VC  1  ,K))/DT1*6.Q 

DO  10  1  *  1 , MM2 
DT2  *  TCI+2)  •  TC1+1 ) 

DV2  *  (VCI+2,0  •  V<  1+1  ,)C))/0T2*6.0 

MCI, 1,10  »  DTI 

MCI, 2,10  «  2.0*CDT1  ♦  DT2) 

MCI, 3,10  *  0T2 
MC 1 ,4,0  *  DV2  •  0V1 

DTI  *  DT2 
DV1  *  DV2 
10  CONTINUE 
C 

C-  SET  UP  PARABOLIC  END  CONDITION  FOR  THE  END  OF  THE  SPLINE. 

C 

MCI, 2,10  *  MC  1 , 2,10  ♦  VC2.IO  •  VC1.IO 
MCNM2,2,K)  -  MCNM2.2.IO  ♦  VCN.IO  -  VCNH1.K) 

C 

C  NOW  UE  SOLVE  THE  TRIDIAGONAL  SYSTEM.  FIRST  REDUCE. 

C 

DO  110  I  *  2,NM2 

MC  1 ,2,10  a  MC  1,2,0  •  MC  1 , 1  ,IO/MC!  - 1 ,2,IO*MC  I  •  1 ,3,10 

MCI,  4,10  =  MCI, 4,10  •  MCI,1,IO/MCI-1,2,IO*MC!-1,4,IO 
110  CONTINUE 

C 

C  NOW  UE  BACK  SUBSTITUTE 
C 

MCNM2,4,K)  *  MCNM2,4,K)/MCNM2,2,K) 

DO  120  I  *  2.NM2 
J  a  NM1  •  I 

MC J, 4,K)  *  CMCJ,4,K)  •  MC J,3,IO*MC J+1 ,4,K))/MCJ,2,IO 

120  CONTINUE 

C 

C  NOW  PUT  THE  VALUES  INTO  THE  S  VECTOR 
C 

DO  130  I  «  1 ,NM2 
SCH-I.K)  »  MCI, 4,10 
130  CONTINUE 

C 

C  FOR  LINEAR  ENDS,  SCI)  =  0,  SCN)  =  0. 

C 

SCI ,K)  =  SC2,K) 

SCN.IO  =  SCNMl.K) 


1000  CONTINUE 
C 

C  CALCULATE  THE  SPLINE  COEFFICIENTS 
C 

DO  200  I  *  1.NH1 
OT  *  TC 1+1 >  -  TCI > 

DO  210  K  =  1,3 

A(  1  ,K)  *  CSCI+1  ,JO  -  S(  I  ,K))/(6.0*OT) 

BC1.IO  *  SCI, K)/2.0 
CO.O  *  (VCI+1.K)  *  V<I,K))/OT  - 
♦  <2.0*0T*SCI,IO  +  0T*S(I+1,IO)/6.0 

00,10  *  VCI.K) 

210  CONTINUE 
200  CONTINUE 

C 

C-  INTERPLOATE  THE  LAST  C  COEFICIENT  USING  THE  PREVIOUS 
C-  SPLINE  POINT 
C 

DT  *  TCN)  •  T(NMI) 

DO  300  K  *  1,3 
A(N,K)  *  0.0 
BCN.K)  ■  SCN, KJ/2.0 

C(N,K)  *  3.0*A(NH1,«*OT«DT  ♦  2,0*B(NM1  ,K)*OT  ♦  CCNMI.K) 
D(N,IO  «  V(N,K) 

300  CONTINUE 

C 

C  ENO  OF  SPLINE  ROUTINE 
C 

ENO 


c 

C»issn>i:i:i:ES3Sai332i:::<:::::33i:<nssi3ni»>3<sssi«3ss:::s:::3: 

c 

c 

C  SUBROUTINE:  GETSEG 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  3BN  LABORATORIES 

C  DATE:  OCTOBER  23,  1986 

C 

C  PURPOSE:  TO  DIVIDE  THE  FLIGHT  INTO  SEGMENTS  WHERE  THE  POINTS  ARE 

C  ABOVE  THE  CRITICAL  MACH  NUMBER.  THE  FIRST  TWO  AND  THE 

C  LAST  TWO  POINTS  OF  A  SEGMENT  CAN  BE  BELOW  CRITICAL.  THIS 

C  IS  DONE  IN  ORDER  OT  IMPROVE  THE  SPLINE  INTERPOLATION. 

C  THERE  CAN  ALSO  BE  SUBCRITICAL  POINTS  IN  THE  TRACK;  HOWEV 

C  THERE  CAN  ONLY  BE  AT  MOST  5.5  SECONDS  BETWEEN  CRITICAL 

C  POINTS.  IF  THERE  IS  A  4.5  SECOND  GAP  BETWEEN  DATA  POINT 

C  THE  SEGMENT  IS  ALSO  TERMINATED. 

C 


c 

PARAMETERS: 

NAME 

TYPE 

DESCRIPTION 

c 

INPUT: 

TIME 

(NPTS) 

R 

ARRAY  OF  TIMES  CS) 

c 

MACH 

(NPTS) 

R 

ARRAY  OF  MACH  NUMBERS 

c 

CA 

(NPTS) 

R 

ARRAY  OF  CLIMB  ANGLES 

(DEG 

c 

Z 

(NPTS) 

R 

ARRAY  OF  NIGHTS  (FEET) 

c 

NPTS 

I 

NUMBER  OF  DATA  POINTS 

L 

c 

OUTPUT: 

START 

(NPTS) 

I 

INDEX  ARRAY  FOR  START 

OF  S 

c 

ENDD 

(NPTS) 

I 

INDEX  ARAY  FOR  END  OF 

SEGM 

c 

NSEG 

I 

NUMBER  OF  SEGMENTS 

C 

C:ss:sss3333asx3SBSS3a:2sszsss3ss:ss=X3S3S3s::Mss3SssM3xss2a3:i33sssss 

c 

c 

SUBROUT  I NE  GETSEG( T IME , MACH , CA , 2 , NPTS, START , ENDD , NSEG  > 

REAL  T I ME ( NPTS ), MACH (NPTS) , CA(NPTS) ,Z(NPTS) 

INTEGER  NPTS 

INTEGER  START (NPTS), ENDD (NPTS), NSEG 
C 

COMMON  /AC1DNT/  IDENT 
CHARACTER*8  IDENT 

COMMON  /ACWEIG/  ACWT.ACL 
C 

COMMON  /CARL/  BOMFCT 
REAL  BOMFCT,  BOMF 
C 

COMMON  /GROUND/  GLAYER , ZGRNO , CGRND ,UGRND , VGRND , REFLFC 
INTEGER  GLAYER 


REAL 


MC, ME, PI , GAMMA 


REAL  BRMAX , MCMAX 

INTEGER  I , F.BKPT 

LOGICAL  STARTED, BREAK, FIRST 


C 

C-  BRMAX  FOR  BREAK  IN  DATA 

C-  MCMAX  FOR  TIME  BELOW  CRITICAL 

C 

DATA  SRMAX/4. 5/, MCMAX/5. 5/, PI/3. 1415927/ 

NSEG  *  0 
I  *  1 
BKPT  *  1 

STARTED  *  .FALSE. 

BOMFCT  *0.0 
FIRST  *  .TRUE. 


100  CONTINUE 

IF  (2(I).GE.6.0E6)  THEN 
NSEG  *  0 
NPTS  *  0 
RETURN 
END  IF 
C 

C-  CALCULATE  CRITICAL  MACH  AND  AIRCRAFT'S  MACH 
C 

MC  *  EXP(4.033E-06*AMIN1 (2(1 ), 35300. )) 

GAMMA  *  CA(I)*PI/1SO.O 
IF  (MACH(I).GT.I.O)  THEN 

ME  =  1 .0/S I N( GAMMA  +  ATAN( 1 .Q/SQRT ( MACH < I )**2  •  1.0))) 
ELSE 

ME  *  0.0 
END  IF 
C 

C-  CALCULATE  THE  PEAK  OVERPRESSURE  USING  CARLESON'S  METHOO 
C 

IF  (ME.GE.MC)  THEN 

PRINT  * , 1 2GRND  2(1)  GAMMA  MACH(I)  HE ' ,2GRND , 2C I ) .GAMMA, 

1  MACHO),  HE 

HE  *  ( 2 (I ) • 2GRNO ) *COS ( GAMMA ) 

ASIGA  *  (1.0  -  6.8756E-06*2O))**5.2559 
ASIGG  *  (1.0  •  6 . 8756E • 06*2GRNO )**5 . 2559 
BOMF  *  (8400.0  *  SORT ( AS  I GA* AS  I GG  )* 

+  (MACHO )**2  -  1  )**0. 125)/(H£**0.75) 

CALL  OPF I ND (I DENT , OPFACT , ACWT ) 

BOMF  *  BOM  F*OP  FACT 
ELSE 

80MF  =  0.0 
END  I  F 

BOMFCT  =  MAX (BOMFCT, BOMF) 

C 

C-  START  A  TRACK 
C 


IF  (ME. GT.MC. AND. .MOT. STARTED)  THEN 
STARTED  *  .TRUE. 

MSEC  ■  NSEG  *  1 
t J  *  MAX0(I-1,2) 

DO  110  1 1 J  *  I ,  I  J, -1 

IF  ((TIME(IIJ)  •  T1NE<  1 1  J*  1 ))  .6T.  BRMAX)  THEN 
SKPT  *  IIJ 
GOTO  120 
ENOIF 

110  CONTINUE 

120  CONTINUE 

START(NSEG)  «  MAX0( BKPT , 1  -  2 ) 

ENOIF 

C 

C-  IS  THERE  A  GAP  IN  THE  DATA  ? 

C 

IF  (I.LT.NPTS)  BREAK  *  (TIME(I*1)  -  TIMEC I ) .GT.3RMAX) 

IF  (STARTED. AND. BREAK)  THEN 
STARTED  *  .FALSE. 

FIRST  *  .TRUE. 

ENDD(NSEG)  a  I 
BKPT  *  I  ♦  1 
ENOIF 
C 

C-  POINT  BELOW  CRITICAL  ? 

C 

IF  (STARTED. ANO. ME. LE.MC)  THEN 
IF  (FIRST)  THEN 
F  *  I 

FIRST  *  .FALSE. 

END  IF 
END  IF 
C 

C-  IS  MACH  BELOW  CRITICAL  LONG  ENOUGH  ? 

C 

IF  (.NOT. FIRST)  THEN 
BREAK  *  (TIME(I)  -  TIME(F).GT.MCMAX) 

IF  (BREAK)  THEN 
STARTED  «  .FALSE. 

FIRST  »  .TRUE. 

ENOO(NSEG)  a  MIN0(F+1 , I ) 

I  a  F  •  1 
ELSE 
C 

C-  ABOVE  CRITICAL  AGAIN 
C 

IF  (ME.GT.MC)  FIRST  a  .TRUE. 

ENOIF 

ENOIF 

C 

C-  LOOP  CONTROLS 
C 

1  =  1  +  1 


IF  ( I .LE.NPTS)  GOTO  100 

IF  (NSEG.GT.O. AMO. STARTED)  ENOO(NSEG)  *  NPTS 

C  CLOSE < 55) 

DO  3333  III  *  1.NSEG 
3333  CONTINUE 

RETURN 

END 


c 

c 

C  SUBROUTINE:  SCREEN 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  NONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  NOVEMBER  3,  1986 

C 

C  PURPOSE:  TO  0EC1DE  WEATHER  THE  MANEUVER  IS  STRONG  OR  WEEK  AND 

C  BASED  ON  THIS  TO.  CALCULATE  AN  ARRAY  OF  PHI  ANGALS 


C 

INDICATING  THE 

RAYS  TO  BE 

TRACED.  FOR  STRONG  MANEUVE 

c 

THE 

GROUND  SPACING  IS  APPROXAMATELY  500  FT.  FOR  WEEK 

c 

p 

MANEUVERS  IT  IS 

2000  FT. 

c 

PARAMETERS: 

NAME 

TYPE 

DESCRIPTION 

c 

p 

INPUT: 

NONE 

L 

c 

OUTPUT: 

PHI  (400) 

R 

:  ARRAY  OF  PHI  ANGLES 

c 

FIRST  ELEMENT  CONTAINS 

c 

INDEX  FOR  THE  FIRST  MA 

c 

LAST  ELEMENT  IS  LAST  M 

c 

c 

p 

NPH  I 

I 

:  NUMBER  OF  ANGLES 

c 

SUBROUTINE  SCREEN(PH1 ,NPH1 ,2GRN0) 

COMMON  /ACSPOT /  TIME ,XRC, YRO ,ZRO,XCOT , YDOT ,ZDOT , AIRSPD , ASPDOT , 

+  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU,  EK(3,3),EKDOT(3, 3),  GLOAD.HEADIN,  CLIMB,  BANK, 

+  XOOOT , YOOOT , ZDOOT , XDDDOT , YDODOT , ZDDDOT 

C 

COMMON  /RAYLIM/  NLIMS, BEGC2) , END<2> 

C 

COMMON  /PHILIM/  MINPHI .MAXPHI 
REAL  MINPHI .MAXPHI 
C 

COMMON  /CARL/  BOMFCT 
REAL  BOMFCT 


REAL  PHI (360) 

INTEGER  NPH I 

REAL  ENOPHI , TMU, DELPHI , P I 

REAL  THETA1 , THETA2.DPHI  ,PH IT, XNOT ,  YNOT , XT ,  YT , XLAST ,  YLAST 
REAL  V(3),A(3),VHAT(3),AHAT(3),WHAT(3), TEMP(3) , MACH , MACHP 
REAL  ALPDOT , MUOOT , THETAS , THETSP , ADOTP, DRAY , MAXD , CLANG 
INTEGER  MNPHI 

EQUIVALENCE  C V< 1 ) ,XDOT ) , ( A< 1 ) , XDDOT ) 


LOGICAL  STRONG, LAST 


C 

C-  OPHI  IS  ONE  DEGREE 
C 

DATA  DELPHI/1 .0/, PI/3. 1415927/, MNPHI/400/ 

CLANG  ■  CLIM8*PI/180.0 
C 

C-  CALCULATE  MAXPH1  0.0  <■  HAXPHI  <*  PI 
C-  CALCULATE  M1XPHI  0.0  »  MIXPHI  >*  PI 
C 

HAXPHI  *  AMOO(AMOO(END(1 ) ,360. )+540. ,360. ) - 1 80 . 

MINPHI  *  AMOO(AMOO(BEG(1) ,360. )+54Q. ,360. >-180. 

C 

C-  CHECK  TO  SEE  IF  THERE  IS  ONLY  ONE  ANGLE 
C 

PHIO  *  0.0 
PHI (2)  *  PHIO 
NPHI  a  2 

IF  (MINPHI. EO.MAXPHI)  THEN 
PHI (1 )  *  0.0 
NPHI  ■  1 
RETURN 
ENOIF 
C 

C-  DO  MANEUVER  SCREENING  AND  SELECT  A  PHI  W1ITH  MAXIMUM  OVER  PREASURE 
C 

MACH  a  SQRT(DOTP<V,V,3)/<C0**2)) 

MACHP  =  DOTP(A, V,3)/(C0*RNORM(V,3) ) 

MUDOT  *  • 1 .0*MACHP/(MACH*SQRT(MACH*MACH  •  1.0}) 

CALL  UNIT(V,VHAT,3) 

CALL  UNIT(A,AHAT,3) 

CALL  CROSS (VH AT ,AHAT , TEMP) 

CALL  CROSS(VHAT, TEMP, WHAT) 

ALPOOT  *  DOTPCA.WHAT ,3)/RNORM(V,3) 

THETAS  *  ASIN( ■ 1 .0*WHAT (3) ) 

C 

C-  CALCULATE  PHI  ANGLE  WITHIN  MARGINS  WITH  THE  LARGEST  OVER  PRESSURE 
C 

IF  (A8S(MUOOT).LT.ABS(ALPOOT+MUDOT))  THEN 
IF  (THETAS. GT.MAXPHI)  THEN 
THETSP  *  MAXPHI 
ELSE 

THETSP  =  THETAS 
ENOIF 
ELSE 

THETSP  =  THETAS  •  PI 
IF  (THETSP.LT. MINPHI)  THEN 
THETSP  *  MINPHI 


ADOTP  *  OOTPC A, WHAT ,3)/RNORM(V,3)*COS(THETSP‘ THETAS) 


ORAY  *  MUOOT+ADOTP 

IF  (ZR0.GT.4572)  THEN 
DPMI  *  DELPHI 
ELSE 

DPHI  *  2. “DELPHI 
EHOIF 

PHI ( 1 )  *  HINPHI 
PHI (2)  ■  AINT (MIMPHI ) 

J  *  2 
C 

C-  CALCULATE  THE  REST  OF  THE  PHI  ANGLES 
C 

1000  CONTINUE 

J  *  J  ♦  1 

PHI(J)  ■  PHI(J-I)  ♦  DPHI 
IF  (PHI(J).LT.MAXPH!)  GOTO  1000 
PHI(J)  *  HAXPHI 
NPHI  »  J 

RETURN 

END 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 
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SUBROUTINE: 

PROGRAMMER: 


DATE: 


STORE 

PHILIP  J.  DAY 
XONTECH  INC. 

8BN  LABORATORIES 
DECEMBER  15,1986 


PURPOSE:  TO  STORE  GROUND  LOCATIONS  AND  OVERPRESSURES  OF  THE  BOOM 

IN  THE  CONTOUR  LIBRARY  FILE  "CLIBRY". 


PARAMETERS: 

NAME 

TYPE 

D I  SCR  I PT I  ON 

INPUT: 

I  FLAG 

I 

CAUSTIC  POINT  INDICATOR 

0  :  SIDELINE  INTERPO 

11  :  NO  CAUSTIC 

21  :  CAUSTIC 

START 

L 

TRUE  FOR  THE  FIRST  POINT  IN 

NEW  TRACK 

TERM 

L 

TRUE  FOR  THE  LAST  POINT  IN  T 

TRACK 

CAUSTC 

L 

SET  IF  THERE  WAS  A  FOCUS  IN  T 

GROUND  REGION 

OUTPUT: 

VARIABLES: 

IKREC 

I 

RECORD  NUMBER  OF  THE  CURRENT 

STORED  RAY  DATA 

ENDREC 

I 

LAST  RECORD  OF  THE  CLIBRY  BE 

ADDITIONS 

FFTFLG 

L 

FLAG  SET  TRUE  IT  AN  FFT  WAS 

CALCULATED  FOR  THE  SEL 

FILBUF 

C 

CHARACTER  BUFFER 

11 

I 

INTEGER  DUMMY  VARIABLE 

12 

I 

INTEGER  DUMMY  VARIABLE 

13 

I 

INTEGER  DUMMY  VARIABLE 

INDREC 

I 

RECORD  NUMBER  OF  THE  ENTRY  I 

INDEX  FILE 

IREC 

I 

RECORD  NUMBER  OF  THE  CURRENT 

IN  THE  CINDEX  FILE 

KREC 

I 

CURRENT  RECORD  TO  BE  WRITEN 

LI 

L 

LOGICAL  DUMMY  VARIABLE 

NOPREC 

I 

NUMBER  OF  PEAK  OVER  PRESSURE 

RECORDS 

NREC 

I 

NUMBER  OF  GROUND  POINT  RECOR 

OP9EC 

I 

STARTING  LOCATION  FOR  PEAK  0 

PRESSURE  RECORDS 

OPC 

R 

PEAK  OVER  PRESSURE  OF  A  CAUS 

OPG 

R 

OVER  PRESSURE  ON  THE  GROUND 

'  PHIO 

R 

PHI  ANGLE  OF  THE  RAY 

SEL 

R 

SOUND  EVENT  LEVEL 

STREC 

I 

STARTING  RECORD  IN  THE  CLIBR 

THE  CURRENT  FLIGHT  TRACK 
R  TIME  THE  RAY  HITS  THE  GROUND 

R  X  COCRDINANT  OF  A  CAUSTIC  RA 

THE  GROUND 

R:A  X,  T,  AND  Z  COORDINANTS  OF  T 
ON  THE  GROUND 

R  Y  COORD  INANT  OF  A  CAUSTIC  RA 

THE  GROUND 

R  Y  COORDINANT  OF  A  CAUSTIC  RA 

THE  GROUND 
C 
C 

SUBROUT  I NE  STORE< I e LAG. START, TERM , CAUSTC , 1 KREC) 

LOGICAL  CAUSTC, ST ART, TERM 
INTEGER  KREC 

COMMON  /GROUND/  GLAYER , ZGRND , CGRND , UGRND, VGRND .REFLFC 
INTEGER  GLAYER 
C 

COMMON  /HACSPT/  HACM(41) 

COMMON  /RAYOUT/  T0,PHI0,XK(3) ,OPG,SEL 
COMMON  /INDEXR/  INOREC 

REAL  TC,XC, YC.OPC 

INTEGER  ENOREC,STREC,NREC,OPREC,NOPREC,IFLAG 

INTEGER  1 1,12, 13, INOREC, IREC 

CHARACTER  FILBUF*98 
COMMON  /PHILIM/  MINPHI .MAXPHI 
REAL  MINPHI, MAXPHI 

C 

LOGICAL  LI , STRTED 

DATA  INOFIL/V,  STRTED/.  FALSE./ 

KREC  *  0 

IF  (START. OR. (.NOT. STRTED. AND. TERM))  THEN 

STRTED  *  .TRUE. 

ENDREC  *  1 
NINOX  *  1 

REA0(52,5000,REC*1 ,ERR=10)  ENDREC 
GOTO  20 

10  ENDREC  »  1 

20  REAO(51,5000,REC*1,ERR*30)  NINDX 

GOTO  40 

30  NINOX  s  1 

40  CONTINUE 

STREC  =  ENDREC  +  1 
NREC  *  0 


READ ( 1N0FIL, FMT* 1 (A) 1 ,REC=I NDREC)  FILBUF 

WRITE (52, 5005 ,REC*STR£C)  FtL8UF(1:36),FIL8UF(55:68),ZGRND 

IF  (.TRUE.)  THEN 

WRIT£<50,5006)  FIL8UFC1 :36) , FILBUF (55 : 68) 

WRITE <50, 5007)  ZGRND/0.3048 
WRITE(50,5200) 

END  IF 
END  IF 

PHIO  ■  AMCO(AMCO(PHIO,360. )*540. ,360. )• 180. 

IF  (.NOT. TERM)  THEN 
NREC  »  NREC  ♦  1 
KREC  *  STREC  ♦  NREC 
IKREC  *  KREC 

WRITE(52,5001,REC=KREC)  1FLAG,HACM(1),HACM(2),HACM(3),KACM<4), 

♦  T0,XK(1 ),XK(2) ,PHIO,OPG,SEL,HACM(14) 

IF  (.TRUE.)  THEN 

C  TOUT  *  T1MCVR(HACM<1),5) 

FX  *  HACM(2)/0.3048 
FY  a  HACM<3)/0.3048 
FZ  «  HACM(4)/0.3048 
FFX  «  XK<1)/0.3048 
FFY  «  XK(2)/0.3048 
AOPG  a  OPG/47.85 

WR I  TE(50, 5004)  I  FLAG,  HACM 1 ) ,  FX,  FY,  FZ,  PHIO,  TO, 

♦  FFX, FFY, AOPG, SEL,HACM(14) 

END  IF 

ELSE 

C 

C-  OUTPUT  THE  MAXIMUM  OVER  PRESSURE  FOR  TIMES  WITH  CAUSTICS 
C 

STRTED  *  .FALSE. 

OPREC  »  0 
NOPREC  a  0 
REWINO  8 

IF  (CAUSTC)  THEN 
500  CONTINUE 

READ(8,5002,£NO=501 )  TT1M,AX,AY,AZ,TC,XC,YC,PHIO,OPG,SEL,COP 

OPREC  *  STREC  ♦  NREC  ♦  1 

NOPREC  a  NOPREC  ♦  1 

JOPREC  *  STREC  ♦  NREC  +  NOPREC 

WRITE (52, 5022, RECaJOPREC)  TTIM,AX,AY,AZ,TC,XC,YC, 

♦  OPG, SEL ,COP 
GOTO  500 

END  IF 
C 

C-  BRANCH  TO  HERE  IF  THERE  ARE  NO  CAUSTICS  IN  THE  FLIGHT  TRACK 
C 


501 


CONTINUE 


READ < I  NO F I L , FMT * • (A) 1 , REC=lNOREC)  FILBUF 
N1NDX  *  NINOX  ♦  1 

WRITE(51,5003,R£C*NIN0X)  F11BUF(1 :68),STREC,NREC,0PR£C, 

♦  NOPREC , CAUSTC 
ENOREC  *  ENOREC  ♦  NREC  ♦  NOPREC  ♦  1 
WRITE(51,5000,REC*1)  nindx 
WRITE(52,5000,REC*1)  ENOREC 

REWIND  8 
END  IF 
RETURN 

801  FORMAT (5F10.4) 

5000  FORMAT(LIO) 

5001  FORMAT ( 12, F8.2,3FS.Q, F8.2.2F8.0, F8.3, F1Q.4, F10.4.F10.4) 

5002  FORMAT(F8.2,3F8.0, F8.2.2F8.0, F8.3, F10.4, F10.4, FI 0.4) 

5022  FORMAT(F8.2,3F8.0,F8.2,2F8.0, F1Q.4, F10.4, F1Q.4) 

5003  FORMAT ( A68 ,  4 1 1 0 ,  L 1 ) 

5004  FORMAT (12, 1X,F10.2,3F8.0,F9.3,F10.2,2F8.0,F11.4,F10.4,F10.4) 

5005  FORMAT(3X,A36,2X,A14, T61 , F10.2) 

5006  FORMAT  < 3X , A36 , 2X , A1 4 ) 

5007  FORMAT(3X, 'ALTITUDE  OF  THE  GRODNO  IS' , F12.2, '  FT.') 

5200  FORMAT ( ' FLAG' ,3X, 'TO' ,7X, ' XO • ,6X, 'TO' ,6X, '20' ,6X, 'PHIO', 

+  7X, 'TG' ,7X, 'XG' ,6X, 'YG' ,7X, 'OP' ,7X, 'CSEL' , 

♦  7X, 'MACH ' ) 


END 


c 

C-  CHECK  TO  SEE  THAT  THE  RAYS  START  AT  THE  SAHE  TIME 
C 

RAY1X  «  XK (15 
RAY1Y  *  XKC2) 

RAY IP  *  OPG 
C 

URITE(BUFF, 1000)  ANG( 1 ) 

REAO(BUFF, 1000)  AAA 
IF  (PHIO  .GT.  AAA)  THEN 
ANGLE3  ■  ANG(1)*PI/180. 

ANGLE2  «  PHI0*PI/180. 

ANGLE1  *  PHI01*PI/180. 

RGRNO  *  .FALSE. 

ELSE 

ANGLE3  *  ANG(1)*PI/180. 

ANGLE2  *  PHIO*P 1/180. 

ANGLE1  *  PHI01*PI/180. 

RGRNO  *  .TRUE. 

END  IF 

C-  DO  THE  EXTRAOPLAT 1 ON 
C 

CALL  EXTRPR (ANGLE 1 , ANGLE2 , ANGLE3 , RGRND , RAYCT ) 


ENOIF 

C 

C-  REPETE  FOR  THE  OTHER  SIDELINE 
C 

IF  (KATTER.GT.O)  THEN 

READ(52,5Q01 ,REC=KATTER)  I  FLAG, HACM< 1 ) , HACM(2) , HACM(3 ) , HACMC4) , 
♦  TO, XK(1),XK<2), PHIO, OPG, SEL, MACH 

K  «  NANG 
200  CONTINUE 

RGRNO  *  .TRUE. 

KK  ■  K 


RAY2X  *  XK(1 ) 
RAY2Y  *  XK(2) 
RAY2P  *  OPG 


RE AO < 52 , 5001 , REC=KATTER • 1 )  I  FLAG , TTT , HACM( 2 ) , HACM(3 ) , 

+  HACM(4),T0,XKC1),XKC2),PHI01, OPG, SEL, MACH 

C 

C-  CHECK  TO  SEE  THAT  THE  RAYS  START  AT  THE  SAME  TIME 
C 


RAY1X 

RAY1Y 


XK  Cl) 
XK(2) 


RAY IP  *  OPG 


WRITECBUFF, 1000)  ANG<1) 

READ (BUFF, 1000)  AAA 
IF  (PHIO  .LT.  AAA)  THEN 
ANGLE3  *  ANG(KK)*P!/180. 

ANGLE2  *  PH IO*P 1/180. 

ANGLE 1  *  PHI01*PI/180. 

RGRNO  «  .FALSE. 

ELSE 

ANGLE3  ■  ANG(1)*Pt/180. 

ANGLE2  *  PHI0*PI/180. 

ANGLE 1  *  PHI01*P!/180. 

RGRNO  *  .TRUE. 

END  IF 

C-  DO  THE  EXTRAOPLAT I ON 
C 

CALL  EXTRPR( ANGLE 1 , ANGLE2 , ANGLE3 , RGRND, RAYCT ) 

END  IF 

1000  FORMAT(F8.3) 

RETURN 

5001  FORMAT ( 12, F8.2.3F8.0, F8.2.2F8.Q, F8.3.F10.4, F10.4, F1Q.4) 

5200  FORMAT (110) 

6000  FORMAT(/‘  !!!!!!!!!!  NOT  ENOUGH  INFORMATION  FOR  EXTRAPOLATION1 , 
♦  ‘1111!  HU!1,/, '  TIME  *‘,F12.3) 

END 


f...*..*.*****.**.****....**.*.*... 


........................  SUBROUTINE  EXTRPRAY  •***••••*•***»»»»*»***»*»* 

............ 

-  MODULE  NAME  :  EXTRPR 

•  MODULE  TYPE  :  SUBROUTINE 

-  PROGRAMMER  :  THOMAS  REILLY 

XONTECH  INC. 

BBN  LABORATORIES 

-  DATE  :  DECEMBER  9,  1986 

-  DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  EXTRAPOLATED  OUTSIDE  TH 
MARGINE  OF  THE  LAST  RAY  DOWN  TO  THE  THRESHOLD  OF  APPROXIMAT 
SEVENTY  08.  IT  ACCOMPLISHES  THIS  BY  RECIEVING  TWO  RAYS  AND 
THREE  ANGLES.  (IF  THE  LAST  RAY  DOES  NOT  HIT  THE  GROUND  THEN 
IT'S  TERMINATION  POINT  IS  CALCULATED  AND  USED  FOR  THE  LAST 
THE  LAST  AND  NEXT  TO  THE  LAST  RAYS  ARE  USE  TO  EXTRAPOLATED 
OUTSIDE  THE  MARGINE  TO  CALACULATE  THE  NEW  RAY'S  TERMINATION 
ANO  OVERPRESSURE. 


VARIABLE  DICTIONARY  : 


ANGLE 1 

ANGLE2 

ANGLE3 

AIRT 

AIRX 

AIRY 

AJRZ 

DM 

DN 

GRNDZ 

LE 

LMC 

PE 

PMC 

RAY1P 

RAY1X 

RAY1Y 

RAY2P 

RAY2X 

RAY2Y 

RAYCT 

RGRNO 

SNOSPO 

TIME 

XE,YE 

XM,  YM 


•  ANGLE  OF  THE  FIRST  RAY  (N-1). 

•  ANGLE  OF  THE  SECOND  RAY  (N). 

•  ANGLE  OF  THE  THIRD  RAY  (M). 

•  TIME  THE  AIRCRAFT  IS  AT  COORDINATE  AIRX,  AIRY,  AIRZ. 

•  X  COORDINATE  OF  THE  AIRCRAFT. 

•  Y  COORDINATE  OF  THE  AIRCRAFT. 

•  Z  COORDINATE  OF  THE  AIRCRAFT. 

•  SLANT  DISTANCE  OF  THE  LAST  RAY. 

•  SLANT  DISTANCE  OF  THE  NEXT  TO  LAST  RAY. 

•  Z  COORDINATE  FOR  THE  GROUND  TERMINATION  POINT  OF  THE  RA 

-  NEW  RAYS  CALCULATED  OVERPRESSURE  IN  OB. 

•  MOO  I F I  ED  OVERPRESSURE  VALUES  IN  DB,  TO  CALCULATE  NEW  RA 

-  NEW  RAYS  CALCULATED  OVERPRESSURE. 

-  MODIFIED  OVERPRESSURE  VALUES  FOR  CALCULATING  THE  NEW  RA 

•  PRESSURE  OF  THE  FIRST  RAY. 

•  X  COORDINATE  OF  WHERE  RAY  ONE  TERMINATES. 

-  Y  COORDINATE  OF  WHERE  RAY  ONE  TERMINATES. 

•  PRESSURE  OF  THE  SECOND  RAY. 

•  X  COORDINATE  OF  WHERE  RAY  TWO  TERMINATES. 

-  Y  COORDINATE  OF  WHERE  RAY  TWO  TERMINATES. 

•  NUMBER  OF  RAYS  IN  THE  ARRAY  RAYPT. 

•  BOOLEAN  FLAG,  TRUE  IF  THE  LAST  RAY  REACHED  THE  GROUNO. 

•  SPEED  OF  SOUND  VALUE. 

■  TERMINATION  TIME  OF  THE  NEWLY  CALCULATED  RAY. 

•  X  AND  Y  COORDINATES  OF  THE  EXTRAPOLATED  RAYS. 

•  X  AND  Y  COORDINATES  OF  THE  LAST  RAY. 


XN,YN  -  X 

ANO  Y  COORDINATES  OF  THE  NEXT  TO  LAST  RAY. 

MODIFIED: 

MARCH  20,  1987 

PRROGRAMMER 

:  PHILIP  J.  DAY 

XONTECH  INC. 

8BN  LABORATORIES 

COMMON  RAYOUT  ADDED 

•  , ,  - 

CALL  TO 

STORE  ADOED 

SUBROUTINE  EXTRPR(ANGL£1 ,  ANGLE2,  ANGLE3,  RGRND ,  RAYCT) 


COMMON  /ACSPT /  AIRT,  AIRX,  AIRY,  AIRZ 

COMMON  /RAYPTS/  RAY1P,  RAY1X,  RAY1Y,  RAY2P ,  RAY2X,  RAY2Y,  GRNDZ, 

+  SNDSPO 

REAL  LN,  PN,  LHC,  PMC,  t£,  PE 
INTEGER  RAYCT,  OUTFILE 
LOGICAL  RGRNO 

COMMON  /RAYOUT/  TO,PHIO,XK(3),OPG,SEL 
PARAMETER  (OUTFILE  *  4) 

RAYCT  *  0 

CHECK  IF  THE  LAST  RAY  REACHED  THE  GROUND. 

I«  (.NOT.  RGRNO)  THEN 

CALCULATE  THE  RAYS  ESTIMATED  COORDINATES  FROM  THE  RAY  BEFORE  I 
XM  *  RAY2X  ♦  (RAY2X  •  RAY1X)  *  ( (TAN(ANGLE3)  •  TAN(ANGLE2)> 

♦  /  (TAN(ANGLE2)  •  TAN(ANGL£1 ))) 

YM  »  RAY2Y  +  (RAY2Y  -  RAY1Y)  *  ( (TAN(ANGLE3)  •  TAN(ANGLE2>) 

+  /  (TAN(ANGLE2)  •  TAN(ANGLE1 ) > ) 

CALCULATE  THE  SLANT  DISTANCE  FROM  THE  A/C. 

DM  «  ((XM  •  AIRX)**2.0  ♦  (YM  -  AIRY)**  2.0  ♦  (GRNOZ  •  AIRZ) 

♦  **  2.0)**  0.5 

ON  a  ((RAY2X  •  AIRX)**2.0  *  (RAY2Y  ■  AIRY)«*2.0  ♦  (GRNOZ  • 

♦  AIRZ)**2.0)**  0.5 

ASSIGN  RAY2  TO  XN  AND  YN  COORDINATE  VARIABLES. 

XN  *  RAY2X 

YN  a  RAY2Y 

CHECK  TO  SEE  IF  SLANT  DISTANCE  LIES  BETWEEN  .8  AND  1.0 
IF  (((0.8  *  DM)  .LT.  ON)  .AND.  (DN  .LT.  DM))  THEN 
LN  =  10  *  LOG10((RAY2P**Z.O) )  +  68.0 
LN  =  LN  •  10  •  103.2  *  L0G10( (DN/DM) ) 

PN  a  RAY2P  «  3. 162*( (ON/DM)**  5.12) 

ELSE 

LN  a  10  •  LOG10( (RAY2P**2.0) )  ♦  68.0 
PN  =  RAY2P 


ENO  IF 


•-  .  CALCULATE  THE  LMC  AND  THE  PMC. 

LAC  «  LN  ♦  15  •  LOG10((DN/DM))  •  10.0 
PMC  «  0.3162  *  PH  *  (OH/OH)**  0.73 

*. 

*-  STORE  THE  LIMIT  POINT 

* . 

TO  *  AIRT  ♦  (DM  /  SNOSPO) 

PHIO  ■  0.0 
XK(1 )  »  XM 
XK(2)  *  TM 
OPG  *  PMC 
SEL  *  0.0 

CALL  STORECO, .FALSE ., . FALSE . , . FALSE . , I REC) 

*  IF  THE  LAST  RAY  DIO  TERMINATE  THEN. 

ELSE 

DM  »  ((RAY2X  -  AIRX)**  2.0  ♦  (RAY2Y  -  AIRY)**  2.0  ♦  (GRND2 

♦  •  AIRZ)**  2.0)**  0.5 

DN  *  ((RAY1X  •  AIRX)**  2.0  ♦  (RAY1Y  -  AIRY)**  2.0  ♦  (GRNOZ 

♦  •  AIRZ)**  2.0)**  0.5 

LMC  *  10  «  LOG10((RAY2P**2.0))  ♦  63.0  -  10.0 
PMC  «  0.3162  *  RAY2P 

*•  ASSIGN  RAY2  TO  XM,  YM  COORINATE  VARIABLES  AND  RAY1  TO  XN,  YN. 

XN  »  RAY IX 
XM  *  RAY2X 
YN  *  RAY1Y 
YM  *  RAY2Y 
END  IF 

INC  *  914.4 

*-  LOOP  UNTIL  LE  *  30. 

10  CONTINUE 

XE  *  INC  *  ((XM  •  XN ) / ( ( (XM  •  XN)**  2.0  +  (YM  •  YN)**  2.0 

♦  )**  0.5))  ♦  XM 

YE  *  INC  *  ((YM  •  YN)/( ( (XM  •  XN)**  2.0  ♦  (YM  -  YN)**  2.0 

♦  >**  0.5))  ♦  YM 

DE  *  ((XE  •  AIRX)**  2.0  ♦  (YE  -  AIRY)**  2.0  ♦  (GRNDZ  • 

♦  AIRZ)**  2.0)**  0.5 

LE  *  LMC  ♦  25  *  LOG10( (DM/DE)) 

PE  *  PMC  *  (DM/DE)**  1.25 

*•  CALCULATE  THE  TIME  THE  RAY  HITS  THE  GROUND. 

TIME  *  AIRT  ♦  (DE  /  SNOSPD) 

*•  CHECK  LE  VALUE  BEFORE  ENTERING  THE  NEW  RAY  IN  THE  FILE. 

IF  (LE  .GE.  80.0)  THEN 
RAYCT  *  RAYCT  ♦  1 

*•  ASSIGN  VARIABLES  IN  THE  COMMON  TO  STORE  VALUES  AND  CALL  STORE. 

TO  =  TIME 
PHIO  *  0.0 


XK(1)  >  XE 
XK(2)  *  YE 
OPG  ■  PE 
SEL  *  0.0 

IF  (((XK(1)  .GT.  -39624}  .AND.  (XK(1)  .LT.  39624)) 

1  .ANO.  ( ( XK C 2 )  .GT.  -39624)  .AMO.  (XK(2)  .LT. 

2  39624)))  THEM 

CALL  STOR£(0, . FALSE . , . FALSE . , . FALSE . , IREC) 

ENOIF 

C  CALL  ENTRAY(XE,  YE,  PE,  TIME,  RAYCT) 

EMOIF 

INC  *  INC  +  914.4 

*•  LOOP  UNTIL  LE  *  80  OB. 

IF  (LE  .GT.  80.0)  GO  TO  10 

CLOSE  (OUT FILE) 

RETURN 

END 

*-  ENO  OF  SUBROUTINE  EXTRPRAY. 


c 

C  SUBROUTINE:  FFUNC 

C  PROGRAMMER:  PHILIP  J.  OAY 

C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  MARCH  25,  1987 

C 


c 

PURPOSE:  TO  GENERATE 

F- FUNCTIONS  FOR  THE  VARIOUS  AIRCRAFT  IN 

c 

THE  TABLE 

.  IF  THE  AIRCRAFT 

TYPE  IS  NOT  FOUND  IN 

c 

THE  TABLE 

,  AN  ERROR  MESSAGE 

IS  PRINTED  AND  PROCESSING 

c 

FOR  THAT 

FLIGHT  IS  ABORTED. 

c 

PARAMETERS :  NAME 

TYPE 

DESCRIPTION 

c 

INPUT: 

c 

TYPE 

C*8 

AIRCRAFT  TYPE 

c 

OUTPUT: 

C 

FOUND 

L 

TRUE  IF  THE  AIRCRAFT 

c 

p 

TYPE  IS  FOUND 

c 

VARAIBLES: 

c 

ACTYPE 

C*8{30) 

ARRAY  OF  AIRCRAFT  TYP 

c 

ACWT 

R 

AIRCRAFT  WEIGHT 

c 

AKS 

R(30) 

ARRAY  OF  KS  VALUES 

c 

FAC 

R(500) 

ARRAY  OF  F- FUNCTION  A 

c 

COEFFICIENTS 

c 

FLC 

RC50O) 

ARRAY  OF  F- FUNCTION  L 

c 

COEFFICIENTS 

c 

KS 

R 

KS  FACTOR 

c 

KSSQ 

R 

(KS**2)  *  3.46 

c 

LEGNTH 

R(3C) 

ARRAY  OF  AIRCRAFT  LEG 

c 

LGN 

R 

AIRCRAFT  LEGNTH 

c 

LGNSOR 

R 

SQUARE  ROOT  OF  LEGNTH 

c 

STEP 

R 

SIZE  OF  EACH  OF  THE  1 

c 

INTERVALS  IN  THE  F-F 

c 

TAU 

R(500) 

ARRAY  IF  F- FUNCTION  L 

c 

WEIGHT 

R(30) 

ARRAY  OF  AIRCRAFT  WEI 

C 

C 

C 


SUBROUTINE  FFUNC (TYPE, FOUND) 

CHARACTER'S  TYPE 

LOGICAL  FOUND 

REAL  AKS(30),LEGNTH(30),WEIGHT(30) 

REAL  KS, LGN, LGNSOR , ACWT , KSSQ , STEP 

CHARACTER'S  ACTYPE(30) 

COMMON  /FFTA8/  KRCAC, NSPOS , SPEEDSC 11), LOCSPDC 1 0) , KTABL , 
NTAU, TAU(200) , FAC (200), FLC(200) 

COMMON  /CFFTAB/  ACIDNT 


CHARACTER'S  AC1DNT 


COMMON  /ACWE1G/  ACWT,ACL 

FOUND  *  .FALSE. 

C 

C-  FINO  THE  AIRCRAFT  TYPE  ICS,  LEGNTH,  AND  WEIGHT 
C 

DO  100  I  *  1,30 

IF  ( TYPE . £0 . ACTYPE ( I )  )  THEN 
KS  «  AKS(I) 

LGN  =  LEGNTH(I) 

A CUT  *  WEIGHT ( I ) 

ACL  *  LEGNTHd  ) *0.3048 
FOUND  =  .TRUE. 

END  IF 

100  CONTINUE 

IF  (FOUND)  THEN 
C 

C-  GENERATE  THE  F- FUNCTION 
C 

STEP  *  LGN*0. 01*0. 3048 
KSSQ  *  3 . 46*KS**2 
LGNSQR  «  SORT (LGN*0. 3048) 

C 

C-  START  WITH  A  LEADING  0 
C 

TAU<1)  *  0.0 
FAC(I)  a  0.0 
FLC(1)  =  0.0 
C 

C-  COMPUTE  THE  101  POINTS 
C 

DO  200  I  «  2,102 

TAU<  I )  *  STEP*REAL( I • 1 ) 

FAC(I)  *  (KSSO*(52.0  •  REAL(I))/50,0)*LGNSOR 
FLC(I)  *  0.0 
200  CONTINUE 
C 

C-  ADO  TWO  TRAILING  ZEROS 
C 

TAU(103)  *  STEP*102.0 
FACC103)  =  0.0 
FLCC103)  a  0.0 
TAUC104)  *  STEP*103.0 
FACC104)  a  0.0 
FLCC104)  a  0.0 
NTAU  =  104 

ELSE 

C 

C-  ACTYPE  NOT  FOUND  PRINT  ERROR  MESSAGE 
C 


WRITE(6,6000)  TYPE 
NTAU  *  0 

ENOIF 


6000  FORMAT (IX, 

+  / ,  1 0X ,  ■  ***’ 

♦  /,10X,'*** 

+  /,10X,'*** 

♦  /,10X,'*** 

+  /,10X,'*** 

♦  /.lOX,1***’ 

♦  /> 


AIRCRAFT  TYPE  ',A8,>  NOT  FOUND 
FLIGHT  ABORTED 


***t 


C 

C-  ADD  A  NEW  AIRCRAFT  TYPE  TO  THE  END  OF  THE  LIST. 

C-  ENTER  THE  APPROPRIATE  KS,  LEGNTH,  AND  WEIGHT  VALUES  IN  THE 
C-  THE  FOLLOWING  DATA  STATEMENTS.  REMEMBER  TO  DECRIMENT  THE 
C-  DUMMY  VALUES  INOROER  TO  KEEP  THE  ARRAY  SIZE  CONSTANT. 

C 


DATA 

ACTYPE 

/ 1 B- 1 

F-4 

1 ,  ‘RF-4 

1 , ' F-5 

♦ 

1  F  - 14 

F- 15 

1 ,  •  F  - 1 6 

' , ■ F- 18 

♦ 

1 F -  20  >, 

F- 101 

■ , ■ F - 1 04 

1 , '  F- 105 

♦ 

1 F- 106 

F-111 

1 ,  'SR-71 

1 , 'T-38 

♦ 

1 4* 1 XXXXXXXX 1  / 

OATA 

AKS 

/  0.0910, 

0.0880, 

0.0880, 

0.0642, 

♦ 

0.0B73, 

0.0838, 

0.0838, 

0.0900, 

♦ 

0.0643, 

0.0860, 

0.0690, 

0.0860, 

■¥ 

0.0840,. 

0.0892, 

0.0870, 

0.0642, 

♦ 

14*0.0/ 

LEGNTH 

IS  IN 

FEET 

DATA 

LEGNTH 

/  147.0, 

58.2, 

63.0, 

46.6, 

♦ 

62.7, 

63.3, 

47.6, 

56.0, 

♦ 

46.5, 

71.1, 

54.8, 

64.2, 

♦ 

70.8, 

75.5, 

107.4, 

46.3, 

♦ 

14*0.0/ 

HEIGHT 

IS  IN 

KLBS. 

DATA 

WEIGHT 

/  453.0, 

56.0, 

55.1, 

19.1, 

♦ 

56.7, 

42.3, 

23.3, 

49.3, 

♦ 

26.1, 

48.4, 

21.4, 

42.7, 

♦ 

34.2, 

95.0, 

161.0, 

11.2, 

♦ 

14*0.0/ 

RETURN 

END 


c 

C  SUBROUTINE:  FOCMAP 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  DECEMBER  21,  1986 

C 

C  PURPOSE:  GIVEN  A  APPROXIMATE  ANGLE  UHARE  THE  MAXIMUM  OVER  PRESS 

C  ON  THE  GROUND  WILL  OCCURS,  TRACE  RAYS  ON  EITHER  SIDE  OF 

C  ANGLE  TO  GET  A  GOOO  SAMPLING  OF  THE  OVER  PRESSURES  ON  T 

C  GROUND. 

C 

C 

SUBROUT I NE  FOCMAP ( TO , NODE , CNOOE , ANG , NANG , RRCURV , CST  FLG ) 

REAL  TO,ANG(400) 

DOUBLE  PRECISION  RRCURV 
INTEGER  NOOE , CNOCE , NANG 
C 

COMMON  /HRPOSN/  HNPTR, HCPOSN , HRT (200) , HRXYZ(200,3) , 

+  HRAGE  <  200 ) , HRPFAC( 200 ) , HRVL  FT , HREMEM 

REAL  HRT , HRXY2 , HRAGE , HRPFAC , HR VL  FT 

INTEGER  HNPTR, HCPOSN 
LOGICAL  HREMEM 
C 

COMMON  /GROUND/  GLAYER , 2GRND , CGRND ,UGRND , VGRND , REFLFC 
INTEGER  GLAYER 
C 

COMMON  /HACSPT/  HACM<41) 

C 

COMMON  /CAUSTC/  NUMC , TRACE, CT(360) , CPHI (360) , CXYZC360 , 3) 

REAL  CXYZ 

LOGICAL  TRACE 
C 

COMMON  /PHI LIM/  MINPHI .MAXPHI 
REAL  MINPHI ,MAXPHI 
C 

COMMON  /HHHH/  HOMEGA,PPK(3) 

REAL  CPHI0<2) 

INTEGER  NCPHI , IREC.OPREC 
LOGICAL  SAVE 
C 

COMMON  /FFTA8/  KRCAC , NSPDS , SPEEDS! 1 1 }, LOCSPD( 10) , KTABL , 

♦  NTAU, TAU(2Q0) , FACC200) , FLCC200) 

COMMON  /CFFTAB/  ACIDNT 

CHARACTER*8  ACIDNT 

W 

COMMON  /8ASEAG/  N TERMS, X I LEADC2) , X I (500) ,XI TA I L(502) , 

*  VLEAD( 2) , V( 500) , VTA  I L  < 502 ) 

DIMENSION  XI I (1004), VI (1004) 

EQUIVALENCE  (XI I  ( 1 ) , X I  LEAD  < 1 ) ) , (VI ( 1 ) , VLEAD! 1 ) ) 


c 

COMMON  /RAYOUT/  TT0,TPHI0,TXK<3) ,TOPG,CSEL 
C 

COMMON  /CARL/  SOMFCT 
REAL  BOMFCT 

REAL  MAXOP 

COMMON  /ACIDNT/  IDENT 
CHARACTER'S  IDENT 

COMMON  /ACWEIG/  ACUT.ACL 

LOGICAL  CSTFLG 

CSTFLG  *  .FALSE. 

SAVE  *  .TRUE. 

MAXOP  =  0.0 
OPREC  =  0 
C 

C-  SAVE  THE  ORIGINAL  AIRCRAFT  FLIGHT  VECTOR 
C 

CALL  TACMOV( TO , NOOE , CNOOE , SAVE ) 

IF  (NOOE.LE.O)  RETURN 
TTO  *  TO 
C 

C-  FIND  THE  ANGLE  OF  CAUSTIC  INTERCECTION  OF  THE  GROUND 
C 

CALL  CSTGNO ( ANG , NANG , CPH 1 0 , NCPH I ) 

IF  (NCPHI.GT.O)  THEN 
CSTFLG  a  -TRUE. 

DO  100  I  »  1 , NCPH I 
XX  a  0 

TPHI  a  CPHIOO) 

CALL  GETOLTCTPHI, ANG, NANG, DELTA) 

110  CONTINUE 

CALL  FOCUSCTO, NOOE, CNOOE, TPHI ,RRCURV, *195 ,*190, *197) 

TPHIO  a  TPHI 
TTO  a  to 

CALL  FOCAL (RRCURV , RAYOP , PMAXP , CCSEL , *195 ) 

CSEL  a  CCSEL 
TOPG  =  RAYOP 
TPHIO  =  TPHI 
IGNO  =  0 
140  CONTINUE 

IGNO  =  IGNO  ♦  1 

IF  (HRXY2(JGND,3).NE.2GRND)  GOTO  140 
TXXC 1 )  a  HRXY2C I GND , 1 ) 


TXKC2)  *  HRXYZ C I GNO , 2 J 
TXKC3)  *  HRXYZCIGN0,3) 

TTO  ■  HRTCIGND) 

FX  *  HACMC2) 

FY  «  HACHC3) 

F2  *  HACM(4) 

FFX  »  TXICCD 
FFY  «  TXKC2) 

AOPG  «  TOPG 
I  FLAG  *  21 

TPHI  ■  AMOOCAMCOCTPHI ,360. )+540. ,360. )- 180. 
WR1TEC12.5004)  IFLAG,HACHC1),FX,FY,FZ,TPH! ,TTO, 
FFX , F  FY , AOPG , CSEL , HACMC 14) 


GOTO  195 
C 

C-  CALCULATE  GROUND  SOLUTION  VIA  THE  TRAPS  METHOO 
C 

190  CONTINUE 

DO  410  IC=1,NTAU 
XI(IO=TAU<K) 

V(K)»FAC(K)+HRVLFT*FLC<K) 

410  CONTINUE 

NTERMS*NTAU 

C 

C-  FIND  THE  INDEX  OF  THE  GROUND  POINT  AND  SAVE  LOCATION  FOR  OUTPUT 
C 

IGND  a  0 
150  CONTINUE 

IGND  *  IGND  ♦  1 

IF  C HRXYZC IGND ,3) .NE . ZGRND )  GOTO  150 
TXKC1)  *  HRXYZ( I GND , 1 ) 

TXK(2)  *  HRXYZC IGND ,2) 

TXKC3)  =  HRXYZC I GND ,3) 

IF  CCXYZC1, 3). GT. ZGRND)  THEN 
CALL  AG  I NGC  HRAGE  C  HCPOSN  *  1 ) ) 

CALL  HIL8RT 
END  IF 

CALL  AGINGCHRAGEC IGND ) ) 

CALL  FNOLYRCHRXYZC IGND, 3), *555) 

555  CALL  AIRCHRXYZCIGND,3)) 

TPHIO  =  TPHI 
TTO  *  TO 

CALL  TSIGPT(RAYOP, IGND) 

TOPG  s  RAYOP 
TPHIO  =  TPHI 
TTO  =  HRT(IGNO) 

FX  “  HACMC2) 

FY  =  HACMC3) 

FZ  *  HACMC4) 


FFX  *  TXXCD 
FFY  -  TXXC2) 

AOPG  »  TOPG 
I  FLAG  *  21 

TPHI  *  AMCOCAMOOCTPHI  ,360.  )+540.  ,360.  >-  ISO. 

WR1 TEC  12, 5004)  I FLAG,HACMC1 ) , FX, FT, FZ, TPHI ,TTO, 
FFX,FFY,A0PG,CSEL,HACMC14) 


GOTO  195 

199  WRITEC7.6006) 

195  TPHI  ■  TPHI  ♦  DELTA 

IF  CTPHI .GE.MINPHI . AND. TPHI .LE.MAXPHI )  GOTO  110 

197  DELTA  «  -1.0*DELTA 

TPHI  *  CPHIOC!) 

XX  «  XX  ♦  1 
IF  (XX.LE.1)  THEN 
TPHI  *  TPHI  ♦  DELTA 
GOTO  110 
END  IF 

100  CONTI HUE 
ENOIF 

RETURN 

5001  FORMATC 12, F8.2.3F7. 0, F8.2.2F7.0, F8.3, FI 0.4, FI 0.4, FI 0.4) 

5002  FORMATCF8.2.3F7.0, F8.2,2F7.0, F8.3,F10.4,F10.4,F10.4) 

5004  FORMATC 12, IX, F10.2.3F8.0, F9.3, F10.2,2F8.0,F11.4,F10.4,F10.4) 
6006  FORMATC  1  *****  FOCAL  ZONE  BEYONO  START  OF  RAY  *****',/, 

♦  .  .....  ABORT  PROCESSING  »*•»*') 

ENO 


c 

. . 

c 

C  SUBROUTINE:  TSIGPT 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  DECEMBER  21,  1986 

C 
C 

C  PURPOSE:  TO  RETRIEVE  PRESSURE  INFORMATION  AND  CALL  SIGPRT  FOR 

C  OVERPRESSURE  CALCULATIONS 

C 

SUBROUTINE  TS1GPT(MAX0P, J) 

REAL  MAXOP 
INTEGER  J 

COMMON  /PRINTS/  T1TL£<30),TIMLBL 
CHARACTERS  TITLE 
CHARACTER*8  TIMLBL 

COMMON  /PR INTO/  XTPSIG.CVRT1M 
LOGICAL  CVRTIM 

COMMON  /BASEAG/  NTERMS  ,XILEAD<2)  ,XU500)  .XITAILC502) , 

♦  VLEAD<2) , V<500), VTAILC502) 

DIMENSION  XII(1004),VI(1 004 ) 

EQUIVALENCE  (XI I < 1 ) ,XI LEAD! 1 ) >, (VI ( 1 >, VLEADC 1 ) > 

COMMON  /SIGPAR/  KGMH , NRCURV, IUPOUN ,XMACH ,VLI FT , TO, 

♦  PHIO, SIGMA, XK<3>, OMEGA, PK(3),XKS(3),XKT(3), 

♦  XKF<3),PFACT,NAGES,AGES<20) 

COMMON  /SIGPAC/  1DENT.RAYNAM 
CHARACTER‘8  IDENT.RAYNAM 

INTEGER  KGMH, NRCURV, lUPDUN 

COMMON  /HRPOSN/  HNPTR , HCPOSN , HRT(200) , HRXYZC200 ,3) , 

♦  HRAGE ( 200 ), HRPFAC ( 200  >, HR VL  FT , HREMEM 

REAL  HRT , HRXYZ , HRAGE , HRPFAC , HRVLFT 

INTEGER  HNPTR, HCPOSN 
LOGICAL  HREMEM 
C 

COMMON  /GROUNO/  GLA YER , 2GRND , CGRND , UGRND , VGRNO , REEL FC 
INTEGER  GLAYER 
C 

COMMON  /CAUSTC/  NUMC , TRACE , CTC360) , CPH I (360) , CXYZ(360 ,3) 

REAL  CXYZ 

LOGICAL  TRACE 

COMMON  /HHHH/  HOMEGA,PPK(3) 


DO  100  I  =1,3 


100 


XK( 1 )  »  HRXYZCJ, 1) 

px(n  *  ppku) 

CONTINUE 

OMEGA  *  HOMEGA 
PFACT  *  HRPFACC J) 


CALL  S1GPRT (MAXOP) 


1 


« 


c 

C  SUBROUTINE: 

C  PROGRAMMER: 

C 
C 

C  DATE: 

C 

C  PURPOSE:  TO  IDENTIFY  THE  PHI  AHGLE(S)  AT  THE  POINT(S)  WHEN  A  CAU 

C  SURFACE  INTERCECTS  THE  GROUND. 

C 

c 

SUBROUT  I NS  CSTGND ( PH  I , NPH 1 , CPH 1 0 , NCP H I ) 

REAL  PHI (400) ,CPHI0<2) 

INTEGER  NPHI.NCPHI 

PARAMETER  (NOIVS=20) 

COMMON  /GROUNO/  GLAYER , ZGRND , CGRND ,UGRND , VGRND , REFLFC 
INTEGER  GLAYER 
C 

COMMON  /PHILIM/  MINPHI .MAXPH1 
REAL  MINPHI.MAXPHI 
C 

COMMON  /CAUSTC/  NUMC, TRACE, CT(360) ,CPHI (360) , CXYZC360.3) 

REAL  CXYZ 
LOGICAL  TRACE 

REAL  ZMIN1,ZMIN2,S(360,3),A(360,3),B(360,3),C(360,3) 

REAL  D ( 360 , 3 ) 

INTEGER  IMIN1 , IMIN2, I2RO(2) 

LOGICAL  POS I  TV 
C 

C-  STATEMENT  FUNCTIONS 
C 

REAL  SPLN 

LOGICAL  OPSIGN 

SPLN(DT , I , J )  *  A( I , J )*0T**3  +  B(I,J)*0T**2  ♦  C(I,J)*DT  ♦  D(I,J) 
OPSIGN(AAA,BBB>  *  ( ( AAA*BB8) .LE.Q. 0) 

NCPHI  =  0 


CSTGND 

PHILIP  J.  DAY 
XONTECH  INC. 

BBN  LABORATORIES 
DECEMBER  12,  1986 


C 

C!nsKasssssas*sn*sssats:sa«assssssas=s5Ssss8ais«M*as:ssss 


IF  (NUMC.LE.1)  THEN 

IF  ( CXYZ ( 1 , 3 ) . GE . ZGRND ■ 457 . 2 . AND . 
CXYZC 1 ,3) . LE . ZGRNO+304.3)  THEN 
CPH 1 0(1)  =  CPHI(I) 

NCPHI  =  1 
END  IF 
RETURN 


ENOIF 

IF  (NUMC.LE.2)  THEM 

CPHIO(I)  *  REAL(INTERP(CPH1  (1 )  ,CPHI  (2),  CXYZO ,3) ,CXYZ(2,3) , 
ZGRND ) ) 

IF  (CPHI (1 ) .GE.MINPHI .ANO.CPHI (1 ).LE .MAXPHI )  THEM 
NCPHI  *  1 
END  IF 
RETURN 
ENOIF 


CALL  SPLINE(CPHI ,CXYZ,NUMC,360,S,A,B,C,D) 

POSITV  =  .FALSE. 

NCPHI  »  0 
ZMIN1  *  1000000.0 

DO  100  I  a  1.NUMC 

IF  (CXYZ(I,3).LT.ZMIN1)  THEN 
ZMIN1  =  CXYZ( I ,3) 

IMIN1  *  I 
ENOIF 

IF  (CXYZ(l,3).GT.ZGRNO)  POSITV  *  .TRUE. 

100  CONTINUE 

C . 

C 

C-  CASE  1:  IDENTIFIED  CAUSTIC  POINTS  ARE  ALL  ABOVE  THE  GROUND 
C 

IF  (ZMIN1 .GT.ZGRNO)  THEN 
IF  (IMIN1.E0.1)  THEN 

IF  ( CPH I ( 1 ) . GT . PH  I ( 1 ) )  THEN 
NCPHI  *  NCPHI  ♦  1 

CPHIO(NCPHI)  =  (CPHI(I)  -  CPHI (2) )/(CXYZ(1 ,3)  •  CXYZ(2,3>) 

♦  (ZGRND  •  CXYZ(1 ,3) )  ♦  CPHI C 1 3 

IF  (CPHIO(NCPHl).lT.PHI(l))  CPHIO(NCPHI)  *  PHI C 1  5 
ELSE 

IF  ( ZM I N 1 .  GT . ZGRND+304 . S )  THEN 
RETURN 
ELSE 

NCPHI  «  NCPHI  ♦  1 
CPHIO(NCPHI)  *  PHI(1) 

END  IF 
ENOIF 
ELSE 

IF  (IM1N1.EO.NUMC)  THEN 

IF  (CPHI (NUNC) . LT .PHI (NPHI ) )  THEN 
NCPHI  =  NCPHI  ♦  1 

CPHIO(NCPHn  =  (CPHI  (NUMC)  -  CPHI  (NUMC- 1  )  )/ 

♦  (CXYZ(NUMC,3)  •  CXYZ(NUMC-1,3))  * 

♦  (ZGRND  ■  CXYZC NUMC .3) )  +  CPHI(NUMC) 

IF  (CPHIO(NCPHI).GT.PHI(NPHD)  CPHIO(NCPHI)  =  PHI  (NPHI  ) 
ELSE 

IF  (ZMIN1 ,GT. ZGRND+304. 8)  THEN 


RETURN 

ELSE 

NCPHI  x  NCPHI  +  1 
CPHIO(NCPHI)  *  PHI(NPHl) 

END  IF 
ENOIF 
ELSE 
C 

C-  PHI  ANGLE  IS  NOT  AT  THE  END  OF  THE  ARRAY  SO  WE  CAN  USE  A  CUBIC 
C-  SPLINE  FOR  INTERPOUT  I  ON. 

C 

IF  (CXYZ( ININl  ■  1 ,3).LT.CXYZ(IMIN1+1 ,3))  THEN 
IMIN2  «  ININl 
IMIN1  x  IM1M1  •  1 
ELSE 

IHIN2  >  ININl  ♦  1 
END  IF 

OPHI  «  ABS(PH1 ( IHIN2)  •  PHI (ININ 1 )) /REAL (NO I VS) 

ZMIN  x  ZM INI 

TPHIO  »  CPHl(IMINI) 

DO  200  I  x  1 , NO  I VS 
OT  «  OPHI  *  REAL C 1 ) 

ZNIN2  *  SPLN(OT, ININl ,3) 

IF  (ZNIN2.LT. ZNIN)  THEN 
ZMIN  x  ZHIN2 

TPHIO  x  CPHI(IMINI)  +  OT 
END  IF 

200  CONTINUE 

IF  (ZMIN.LE.ZGRN0+304.8)  THEN 
IF  (ZNIN.GE.ZGRND)  THEN 
NCPHI  x  NCPHI  ♦  1 
CPHIO(NCPHI)  x  TPHIO 
ELSE 
C 

C-  WE  HAVE  THE  CURVE  INTERCECTING  THE  GROUND  IN  TWO  PLACES. 

C-  NOW  CHECT  TO  SEE  IF  THE  LOWEST  POINT  ON  THE  CURVE  IS  BELOW 
C-  OR  ABOVE  GROUND- 1000  FT. 

C 

C-  IF  IT  IS  BELOW  THEN  FIND  THE  ZERO  ON  EITHER  SIDE  USING  THE 
C-  BICECTION  METHOO  OF  ROOT  FINDING 
C 

IF  (ZMIN.LT.ZGRND-457.2)  THEN 
DO  250  I  x  1,2 
IF  (I .EQ. 1 )  THEN 
PHIA  x  CPHI(IMINI) 

PHIB  x  TPHIO 
ELSE 

PHIA  x  TPHIO 
PHIB  =  CPHI(IMINZ) 


ENO 1 F 

PA  *  PHIA 

PB  *  PH1B 

PC  »  (PA*P8)/2.Q 

ERR  »  ABS(PA-P8>/(2000.0*REAL(ND!VS>) 

255  COMT!MUE 

OPS  ■  PB  *  CPHI ( IMIN1 ) 

OPC  ■  PC  •  CPHK1MIN1) 

SP1  *  SPLNCDPB,  IHIN1 ,3)  -  ZGRNO 
SP2  ■  SPLN(DPCt IMIN1 ,3)  •  ZGRNO 
IF  (OPSIGM(SP1,SP2))  THEN 
PA  ■  PC 
ELSE 
PB  ■  PC 
ENO  IF 

PC  *  (PA*PB>/2.0 
IF  ((PB-PC).GT.ERR)  GOTO  255 
CPHI 0(1 )  *  PC 

250  CONTINUE 

NCPH1  »  2 
ELSE 
C 

C-  HIN  Z  IS  ABOVE  GROUND-1000  FT.  SET  NCPHI  NEGATIVE  AS  A  FLAG 
C 

NCPHI  «  NCPHI  ♦  1 
CPHIO(NCPHI)  *  TPH-IO 
NCPHI  *  -1*NCPH! 

ENO  IF 
ENO  IF 
ELSE 
RETURN 
ENO  IF 

ENO  IF 
ENO  IF 

RETURN 
ENO  IF 

C . 

c 

C-  CASE  2:  CAUSTIC  SURFACE  IS  BELOW  THE  GROUND 
C 

IF  ( .NOT.POSITV)  THEN 

IF  (CPHI ( l).EQ.PHI(D)  THEN 
NCPHI  =  NCPHI  ♦  1 
CPHIO(NCPHI)  =  CPHI(I) 

ENO  IF 

IF  (CPH I (NUMC) . EQ . PHI (NPH I > )  THEN 
NCPHI  =  NCPHI  +  1 
CPHIO(NCPHI)  =  CPHI(NUMC) 


END  IF 


RETURN 
END!  F 
C . 

c 

C-  CASE  3:  CAUSTIC  SURFACE  INTERCECTS  THE  GROUND 
C 

DO  300  I  *  1 ( NUMC • 1 

IF  (OPSIGNCCXYZO  ,3)-ZGRND ,CXYZ( 1+1 ,3)*ZGRND))  THEN 
NCPHI  »  NCPH!  ♦  1 
IZROCNCPHI )  *  I 
END  IF 

300  CONTINUE 
C 

C-  CHECK  TO  SEE  IF  CAUSTIC  SURFACE  IS  ABOVE  GROUND- 1000.  FT. 

C 

IF  ( IMIN1 .EQ.NUMC)  THEN 
IHIN2  *  IHIN1 
IMIN1  =  IMIN1  •  1 
ELSE 

IF  (IMIN1.EQ.1)  THEN 
IMIN2  «  2 
ELSE 

IF  <CXYZ(1MIN1-1,3).LT.CXYZ(IMIN1+1,3>>  THEN 
IM1N2  «  IMIN1 
IMIN1  ■  IM1N1  •  1 
ELSE 

IM1N2  *  IMIN1  ♦  1 
END  IF 
END  IF 
END  IF 

DCPHI  *  ABS(PHI (1HIN2)  -  PHI < IMIN1 ) )/REAL(NDI VS) 

ZMIN  *  ZMINl 

DO  500  I  *  1 , HD  I VS 
DT  s  DPMI  *  REAL ( I ) 

ZMIN2  *  SPLN(DT, I Ml  Ml ,3) 

IF  (ZMIN2.LT. ZMIN)  THEN 
ZMIN  i  ZMIN2 

TPH10  =  CPHI(IMINI)  +  OT 
ENOIF 

500  CONTINUE 

IF  ( ZM I N . GE . ZGRND -457.2)  THEN 

IF  ( (ABSCCPH1 ( IMINl )  -  CPHI ( IMIN2) ) )  .LE.  (ABS(PHI(2) 
1  PHI(3))>)  NCPHI  =  1 

END  IF 

C 

C-  USE  THE  bicection  method  of  root  finding  to  find  the  zero 
c 


DO  400  I  =  1, NCPH I 


PA  *  CPH1(IZR0(I)> 

PB  *  CPHI(IZRO(I)*1) 

PC  *  (PA+P8)/2.0 

ERR  «  ABS ( P A - PB ) / ( 2000 . 0*REAL ( NO  I VS ) ) 

410  CONTINUE 

OPB  a  PB  •  CPHI ( IZRO( I ) ) 

OPC  *  PC  •  CPHI(IZROO)) 

SP1  >  SPIN (DPS , IZRO( I } ,3)  •  ZGRND 
SP2  a  SPLN(DPC,IZR0(n,3)  •  ZGRNO 
IF  (0PSIGN(SP1,SP2)>  THEN 
PA  -  PC 
ELSE 
PB  a  PC 
END  IF 

PC  »  (PA+PB)/2.0 

IF  ( (PB - PC ).GT. ERR)  GOTO  410 

CPHI 0(1  )  «  PC 

400  CONTINUE 

RETURN 

ENO 


c 

C  SUBROUTINE:  FOCUS 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  3BN  LABORATORIES 

C  DATE:  OECEMBER  16,  1986 

C 

C  PURPOSE:  TO  LOCATE  A  CAUSTIC  SURFACE  AND  ITS  RELITIVE  CURVATURE 

C  AT  THE  RAY  LOCATION. 

C 

C  PARAMETERS: 

C  INPUT: 

C 
C 

c 
c 

c  OUTPUT: 

C  RRCURV 

C 

C  ALT  RETURN  1 

C 

C  ALT  RETURN  2 

C 

C  ALT  RETURN  3 

C 
C 
C 
c 

SU8ROUT I NE  FOCUSC  TO , NNOOE , NCNOOE , ANG , RRCURV ,»,»,* ) 

REAL  TO, ANG 

DOUBLE  PRECISION  RRCURV 
INTEGER  NODE , CNOOE 

COMMON  /ACSPOT /  TIME, XRO , YRO , ZRO , XDOT , YDOT , ZDOT , A I RSPD , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU, EK(3,3) , EKDOTC3 ,3) , GLOAD , HEAD  I N , CLIMB , BANK, 

♦  XDOOT , YODOT , ZDOOT , XDDDOT , YDDDOT , ZDDDOT 

COMMON  /RAYN I T/  KGMH , NOCRVS , NUCRVS , I UPDWN , TRO , PH  1 0 , XO , TO , ZO , 

♦PI  0 , P20 , P30 , OMEGA .OELTAO , PI FO , P2F0 , P3F0 , OMEGAF, XTO , YTO , ZTO , 
♦P1TO,P2TO,P3TO,OMEGAT,XSO,rSO,ZSO,P3SO,RHOO,PCONST,NAG£S,AGES(20) 
I NTEGER  KGMH , NOCRVS , NUCRVS , IUPDWN 
LOGICAL  8ETWEN 
C 

COMMON  /GROUND/  GLAYER , ZGRNO , CGRNO , UGRND , VGRND , REFLFC 
INTEGER  GLAYER 
C 

COMMON  /CAUSTC/  NUMC , TRACE , CT ( 360 ) , CPH I (360) , CXYZC360 , 3) 

REAL  CXYZ 


R  RADIUS  OF  CURVATURE  OF  THE  CAU 
SURFACE 

*  TAKEN  IF  ONE  OF  THE  RAYS  RECUR 

ABOVE  THE  GROUND 

*  TAKEN  IF  ONE  OF  THE  AUXILIARY 

HAS  NO  CAUSTIC 

*  TAKEN  IF  THE  ORIGIONAL  RAY  HAS 

CAUSTIC,  OR  THE  CAUSTIC  IS  M 
THAN  500  FT.  ABOVE  THE  GROUN 


NAME  TYPE  01  SCRIPT I ON 

NCOE  I  INDEX  INTO  THE  FLIGHT  TRACK  AR 

CNOOE  I  INDEX  INTO  THE  SPLINE 

ANG  R  PHI  ANGLE  OF  THE  ORIGIONAL  RAY 


LOGICAL  TRACE 


COMMON  /RPOSN/  NPTR , CPOSN , ST ( 200 ) , RXYZ ( 200 , 3 ) , RAGE ( 200 ) , 
RPFACT(200),RVLIFT, REMEM 
REAL  RT, RXYZ, RAGE, RPFACT,RVL1 FT 
INTEGER  NPTR, CPOSN 
LOGICAL  REMEM 


C 


COMMON  /ACYEIG/  ACWT.ACL 


DOUBLE  PRECISION 
DOUBLE  PRECISION 
DOUBLE  PRECISION 
DOUBLE  PRECISION 


RRAY1 (3) ,RRAY2(3) , RRAY3(3) ,RRR(3) ,RRRR 
RCURV(3) ,CCURV(3) ,RELCUR(3) 

XXX 

DOOTP.DRNORM 


REAL  DELR1 (3) ,DELR2(3) , VEL0,D£LV 

REAL  V(3) , A(3) , VHAT (3) ,AHAT (3) , WHAT (3) ,MACH , MACHP ,MUDOT 
REAL  ALPOOT, EDOT.DLTAT, TTO, PHIO, TT(3), THETAS, TEMP(3), PI 
REAL  DL{7) 


LOGICAL  SAVE, NOSAVE, RCBLG.CFLAG 


EQUIVALENCE  (V.XDOT), (A.XDOOT) 


DATA  SAVE/ . TRUE . / , NOSAVE/ . FALSE ./ ,DDLPH I /0 .5/ .DLTAS/243 . 84/ 

DATA  P I /3 . 14 1 59263/ ,  OCTR/0/ , KKTB/0/ 


NOOE  «  NNOOE 
CNOOE  *  NCNOOE 

CALL  TACMOVf TO, NOOE, CNOOE, NOSAVE) 
IF  (NOOE.L E.O)  RETURN  1 


NPTR  =  0 
NUMC  *  0 
TRACE  =  .TRUE. 
REMEM  =  .TRUE. 


VELO  *  RNORM(V,3) 

PHIO  *  ANG 
IF  (ANG. NE. 0.0)  THEN 
OLPHI  *  DDLPH I *ANG/A8S ( ANG ) 

ELSE 

DLPHI  *  DDLPHI 
ENOIF 

CALL  RAYORG(*5001 ) 

CALL  RAYTRKC . FALSE . , RCBLG , CFLAG , *5001 ) 
CALL  SAVRAY 
C 

C-  NO  CAUSTIC  ON  THE  RAY 
C 

IF  (NUMC.LE.O)  THEN 
KXTB  =  KKTB  *  1 
IF  (KKTB  .GT.  1)  THEN 
KKTB  =  0 
RETURN  3 


ELSE 


RETURN  2 
END  IF 
ENOIF 
KKTB  *  0 
C 

C-  CAUSTIC  500  FT.  OR  MORE  ABOVE  THE  GROUND 
C 

IF  ( RXYZ ( CPOSN , 3 ) . GT . 2GRND+304 .8)  THEN 
KKTR  =  KKTR  +  1 
IF  (KKTR.GT. 1 )  THEN 
KKTR  *  0 
RETURN  3 
ELSE 

RETURN  2 
ENOIF 
ENOIF 
KKTR  *  0 
C 

C-  CALCULATE  RAY  CURVATURE 

c 

IF  (CPOSN. GE. 5)  THEN 
J1  *  2 
ELSE 
J1  =  1 
ENOIF 
J2  »  2*J1 

DO  100  I  *  1,3 

RRAYI(I)  *  DBLE(RXYZ(CPOSN, I )) 

RRAY2CI)  =  DBLE ( RXYZ ( CPOSN- J1 , I ) ) 

RRAY3( I }  =  DBLE (RXYZ (CPOSN - J2, I )) 

100  CONTINUE 

CALL  CURVE ( RRAY 1 , RRAY2 , RRAY3 , RRR , RRRR ) 

DO  200  I  =1,3 

RCURV(I)  =  - 1 . 0*(DBLE(CXYZ(1 ,1)5  -  RRR( I )  )/(RRRR**2 ) 
200  CONTINUE 
C 

C-  TRACE  THE  RAYS  FOR  THE  PHI  INC  CALCULATIONS 

C-  RAY  2 
C 

1000  PH  1 0  =  ANG  *  DLPHI 
CALL  RAYORG(*5001) 

CALL  RAYTRK(  .FALSE. , RCBLG , CFLAG, *5001) 

IF  (ABS(CT(2)-CT(1)).GT.0.5)  RETURN  1 
CALL  FINDT(2,«1000) 

MACH  =  SGRT(DOTP(V,V,3)/(CC**2>) 

MACHP  =  DOTP(A,V,3)/(CO*RNORM(V,3)) 

MUOOT  =  - 1 .0*.IACHP/(NACH*SORT(MACH*NAC.H  ■  1.0) > 


CALL  UN  I T ( V , VHAT ,3) 


CALL  UNIT(A,AHAT,3) 


CALL  CROSS (VHAT,AHAT, TEMP) 

CALL  CROSS (VHAT, TEMP, WHAT) 

THETAS  *  ASI N(  •  1 . 0*WHAT (3) ) 

EDOT  *  DOTP(A,UHAT,3)/RNORM(V,3)*COSUANG*PI/180.Q)-THETAS) 

C  DLTAT  «ABS<OLPHt/<<MUOOT  ♦  EDOT)* 150. 0/P1 )/C0) 

DLTAT  ■  ABS( (DLPHI*PI/180.0)*4.6*ACL/C0/$QRT <MACH*MACH  -  1.0)) 


TTO  *  TO  +  OLTAT 


MODE  a  NNGOE 
CNOOE  *  NCNOOE 

CALL  T ACMOV ( TTO , NODE , CNOO  E , NOSAVE ) 

If  (NOOE.LE.O)  RETURN  1 
C 

C-  RAY  3 
C 

PHIO  >  ANG 

CALL  RAYORG(*5001 ) 

CALL  RAYTRKC . FALSE . , RC8LG, CFLAG,*5001 ) 
IF  (ABS(CT(3)-CT(1 )).GT .0.5)  RETURN  1 
CALL  FINOT(3,*1000) 

C 

C-  RAY  4 
C 

PHIO  =  ANG  ♦  DLPHI 
CALL  RAYORGC5001) 

CALL  RAYTRKC . FALSE . , RCSL G , CFLAG , *5001 ) 
IF  ( A8S (CT(4)-CT(1)).GT.0.5)  RETURN  1 
CALL  FINDT(4 , *1000) 

C 

C-  CALCULATE  PHI  INC 
C 

DO  300  I  *  1,3 

OELRI(I)  *  CXYZ(3,I)  -CXYZ(1,I) 
DELR2C I )  *  CXYZ{4, 1 )  -CXYZ(3,I) 

300  CONTINUE 


DO  302  I  =  1,6 
DL( I )  s  0.0 
302  CONTINUE 

DO  301  I  =  1,3 
DLC 1 )=(CXYZ(2, I ) 
DL(2)=(CXYZC3, I) 
DL(3)='CXYZ(4, 1 ) 
DL(4)3(CXYZ(3,I) 
DL(5)=(CXYZ{4, 1  ) 
DL(6)3(CXYZ(4, 1 ) 


- CXYZ<  1,1)  )«»2  ♦  DUD 
-CXYZC1 , I ))**2  ♦  DLC2) 
- CXYZ< 1,1) )**2  ♦  DL(3) 
■CXYZ<2, 1))**2  *  DL (4 ) 
•CXYZ(2, I ))**2  *  DL (5 ) 
•CXYZ(3, I))**2  *  DL(6) 


301  CONTINUE 


PHI  INC  =  -1 .0*(DOTP(D£LR1 ,DELR2,3)*0LPHI )/ 

+  RNORM(DELR2,3)**2/(VELO*OLTAT) 

TT(1)  *  TO  -  OLTAS/(HACH*CO) 

TT(2)  =  TO  +  DLTAS/(MACH*CO) 

TT(3)  *  TO  •  2.0*DLTAS/ (MACH'CO) 

NUMC  *  1 

CALL  FINDTCl ,*5001 ) 

DO  400  I  *  1,3 
NODE  •  NNCCE 
CNOOE  :  NCNOOE 

CALL  TACHOV(TT(I ) ,NCOE , CNOOE , NOSAVE) 

IF  (NOOE.LE.O)  RETURN  1 

DELV  *  (VELO  ♦  RNORM(V,3))/2.0 

PHIO  »  ANG  +  PHI 1NC*REAL(DELV)*(TT ( I )  •  TO) 

TRACE  *  .FALSE. 

CALL  RAYORG<*400) 

CALL  RAYTRK< .TRUE . ,RCBLG,CFLAG,*400) 

400  CONTINUE 


C 

c-  IF  ONE  OF  THE  AUXILIARY  RAY  TUBES  HAS  NO  CAUSTIC.  USE  TRAPS 
C-  SIGNATURE  CALCULATIONS 
C 

IF  (NUMC.LT. 4)  THEN 

RETURN  1 
ENOIF 
C 

C-  CHECK  FOR  CUSP  STRADLE 
C 

IF  (<CT(4) .GE.CTC2) ) .OR. (CT(2) . GE .CT( 1 ) ) .OR. (CT(1 ) .GE.CTC3) ) ) 
+  THEN 
RETURN  1 
ENOIF 
C 

C-  CALCULATE  RELITIVE  CURVATURE  OF  THE  CAUSTIC  SURFACE 
C 

DO  500  I  *  1,3 

RRAYI(I)  *  CXYZ(1,I) 

RRAY2II)  =  CXYZC2, I ) 

RRAY3(I)  =  CXYZ(3,I) 

500  CONTINUE 

CALL  CURVE (RR AY  1 , RRAY2, RRAY3.RRR , RRRR ) 

DO  600  I  =  1,3 

CCURV(I)  =  •  1 . ODO*(DBLE ( CXYZC 1 , 1 ) )  -  RRR( I) )/ ( RRRR**2) 

600  CONTINUE 


XXX  *  1.000  -  DOOTP(RCURV,CCURV,3)/(DRNORM(CCURV,3>**25 


00  700  I  *  1,3 
REICUR(I)  *  XXX*CCURV( I ) 

700  CONTI HUE 

RRCURV  =  1.O0O/ORNORM(REICUR,3) 

RETURN 

5000  RETURN 
C 

C-  ONE  OF  THE  RATS  RECURVES  BEFORE  IT  REACHES  THE  GROUND.  WE  CAN  NOT 
C-  PROCESS  THIS  CASE 
C 

5001  RETURN  1 
END 


i 


i 

m 


J 


c 

. . 

c 

C  SUBROUTINE:  TACMOV 

C  PROGRAMME* :  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  B8N  LABORATORIES 

C  OATE:  DECEMBER  16,  1986 

C 

C  PURPOSE:  TO  CALL  ACMOVE  AND  TO  SAVE  COR  NOT)  THE  STATE  VECTOR 

C  AS  REQUIRED. 

C 

C  PARAMETERS: 

C  INPUT: 

C 
C 

c 
c 
c 
c 

C  OUTPUT :  NONE 

C 

C 

SUBROUT  I NE  T ACMOV ( T  0 , NOOE , CNOOE , SAVE ) 

REAL  TO 
INTEGER  NOOE, CNOOE 
LOGICAL  SAVE 

COMMON  /ACSPOT /  T IME ,XR0, YRO, ZRO.XDOT , YOOT ,ZDOT , AI RSPD , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMAOOT , XMU , XMUDOT , COSMU , 

♦  SINMU,EK<3,3),EKDOT(3,3),GLOAD,HEADIN,CLIM8,BANK, 

♦  XDOOT , YOOOT , ZDDOT , XDDDOT , YDDOOT , ZDDDOT 

COMMON  /HACSPT/  HACM 

REAL  ACM(41 ) , HACMC41 ) 

EQUIVALENCE  CACMC 1 ) , TIME ) 

CALL  ACMOVECTO, NOOE, CNOOE) 

IF  (SAVE)  THEN 
DO  100  I  *  1,41 
HACM(I)  *  ACM(I) 

100  CONTINUE 
END  IF 


NAME  TYPE  D I SCRIPT I ON 

TO  R  TIME  USED  TO  COMPUTE  THE  A IRC 

POSITION 

NOOE  I  INDEX  INTO  THE  FLIGHT  TRACK  AR 

CNOOE  I  INDEX  INTO  THE  SPLINE 

SAVE  L  FLAG  FOR  SAVING  THE  STATE  VECT 


RETURN 

ENO 


c 

. . 

c 

C  SUBROUTINE:  SAVRAY 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  SBN  LABORATORIES 

C  DATE:  DECEMBER  16,  19S6 

C 

C  PURPOSE:  TO  SAVE  THE  RAY  TIMES,  LOCATIONS,  AND  AGES  AT  EACH  MESH 

C 

C 

SUBROUTINE  SAVRAY 

COMMON  /RPOSN/  NPTR, CPOSN, RT ( 200 ),RXYZ( 200, 3), RAGE (200), 

♦  RPf ACT(200) , RVLI FT , REMEM 

REAL  RT,RXYZ, RAGE, RPFACT, RVLI FT 

INTEGER  NPTR, CPOSN 

LOGICAL  REMEM 
C 

COMMON  /HRPOSN/  HNPTR , HCPOSN , HRT(200) , HRXYZC200.3) , 

♦  HRAGE ( 200 ) , HRPFAC ( 200 ) , HRVLFT , HREMEM 

REAL  HRT , HRXYZ , HRAGE , HRPFAC, HRVLFT 

INTEGER  HNPTR, HCPOSN 
LOGICAL  HREMEM 
C 

COMMON  /RAYNIT/  KGMH.NOCRVS.NUCRVS, 1UPDUN,TO,PHIO,XO,YO,ZO, 

♦  P10,P20,P30, OMEGA, DELTAO,P1FO,P2FO,P3FO, 

♦  OMEGAF,XTO,YTO,ZTO,P1TO,P2TQ,P3TO,OMEGAT,XSO, 

♦  YSO.ZSO, P3S0 , RHOO , PCONST , NAGES , AGES ( 20 ) 

INTEGER  KGMH , NDCRVS , NUCRVS , I UPDWN 

REAL  XK0(3) ,PK0(3) ,PKF0(3) ,XKT0(3),PKT0(3),XKS0(3) 

REAL  PPJ(3) 

EQUIVALENCE  (PPJ(1),P10) 

COMMON  /HHHH/  HOMEGA,PPK(3) 

HOMcUA  =  OMEGA 

HNPTR  *  NPTR 
HCPOSN  *  CPOSN 
HRVLFT  *  RVLI FT 
HREMEM  :  REMEM 

DO  100  I  »  1 , NPTR 
HRAGE ( I )  *  RAGE ( I ) 

HRPFACC I )  *  RPFACT ( I ) 

HRT ( I )  =  RT  Cl) 

DO  110  J  =  1,3 

HRXYZC I , J )  =  RXYZCI.J) 

110  CONTINUE 
100  CONTINUE 


00  200  I  *  1,3 
ppk(I)  *  ppjcn 
CONTINUE 

RETURN 

ENO 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


SUBROUTINE: 

PROGRAMMER: 


DATE: 


FOCAL 

PHILIP  J.  DAY 
XONTECH  INC. 

S8N  LABORATORIES 
DECEMBER  18,  1988 


PURPOSE:  TO  COMPUTE  THE  OVER  PRESURE  AT  THE  GROUND  WHEN  A  CAUSTI 

BETWEEN  500  FT  AND  -1000  FT  ALTITUDE. 


SUBROUT  1 NE  FOCAL CRRCURV .MAXOP , PMAXP , CSEL , • ) 


DOUBLE  PRECISION  RRCURV 
REAL  MAXOP 


COMMON  /GROUND/  GLAYER , 2GRND , CGRND , UGRND , VGRND , REFLFC 
INTEGER  GLAYER 

COMMON  /FFTAB/  KRCAC , NSPOS , SPEEDS! 1 1 ) , LOCSPD ( 1 0 ) , KTABL , 
MT AU , TAU< 200 ), FAC t 2005 , FLC(2Q0) 

COMMON  /CFFTAB/  ACIDNT 
CHARACTER'S  ACIDNT 

COMMON  /BASEAG/  NTERMS.XI LEAO<2) ,Xt (500) ,XITAI L(502) , 
VLEAO(2),V<500),VTAIL(502) 

DIMENSION  XI I C 1004) , VI ( 1 004) 

EQUIVALENCE  (XI I  (1 )  ,XILEA0(  1 )),  (VI  (1 ) ,  VLEADO  ) ) 

COMMON  /PRESUR/  PRS,C 
REAL  PRS,C 

COMMON  /CAUSTC/  NUMC, TRACE , CT(360 ) , CPHI (360) , CXYZ(360,3) 
REAL  CXYZ 
LOGICAL  TRACE 

COMMON  /RPOSN/  NPTR, COPSN , RT (200) , RXYZt 200,3) , RAGE ( 200 ) , 
RPFACT ( 200 ) , RVL I  FT , REMEM 
REAL  RT.RXYZ, RAGE, RPFACT, RVL 1  FT 
INTEGER  NPTR, COPSN 
LOGICAL  REMEM 

COMMON  /HRPOSN/  HNPTR , HCPOSN , HRT ( 200) , HRXYZ(200 ,3) , 

HRAGE(200),HRPFAC(200),HRVLFT,HREMEM 
REAL  HRT , HRXYZ , HRAGE , HRPFAC , HRVLFT 
INTEGER  HNPTR, HCPOSN 
LOGICAL  HREMEM 


COMMON  /HHHH/  H OMEGA, PK(3) 


REAL 

REAL 


I NTERP , : I  ST , MAXOPG , MAXOP 1 
XXT (504) , PPT (S04) , PMX , CSEL 


C 

C-  INITIALIZE  THE  F-FUNCTION 
C 

00  200  K*1 ,NTAU 
XI(K)*TAUOO 

V<K)*FACCIC)+HRVLFT*FLC(IC) 

200  CONTINUE 
NTERMSaNTAU 
C 

C-  FIND  THE  GROUND  POSITION 
C 

IGNO  »  0 
100  CONTINUE 

IGNO  »  IGNO  +  1 

IF  (HRXYZC 1GND,3) .ME . ZGRND )  GOTO  ICO 
C 

C-  CALCULATE  THE  OVERPRESSURE  ANO  CP  ON  THE  GROUND  UStING  THE  TRAPS 
C-  METHOD 
C 

IF  (CXYZ( 1 ,3) .GT. ZGRND)  THEN 
CALL  AGING(HRAGE(HCPOSN-m 
CALL  HILBRT 
END  IF 

CALL  AG I NG( HRAGE  < I GND ) ) 

CALL  FNDLYR(HRXYZ(IGND,3),*556) 

556  CALL  A1R(HRXYZ( I GND ,3) ) 

PMAX  a  0.0 
PM IN  *  100.0 
DO  220  K=1 ,NTERMS 

V(K)aV(K)*HRPFAC( I GND )/2. 0 
PMAX=AMAX 1 c  PMAX , V(K) ) 

PMIN=AMIN1(PMIN,V(K)) 

220  CONTINUE 

MAXOPG  *  AMAX1 (ABS(PMIN) ,ABS(PNAX) ) 

DDPP1  a  0.0 

C  DO  300  K  *  1 , NTERMS+1 

C  IF  (XI I (K+1 ) .GE.XI I (K+2) .AND. VI (K+1 ) .LT .VI (K+2) )  THEN 

C  DDPP1  »  AMAXl (D0PP1 , (VI (K+2) -VI (K+1 ) ) ) 

C  ENOIF 

C300  CONTINUE 

IF  (DDPP1.EQ.0.0)  00PP1  =  MAXOPG 


CPGN0=00PP1/1 ,40/PRS*2.0*0.001 
C 

C-  CALCULATE  THE  FOCAL  ZONE  AND  THE  FOCUS  OVERPRESSURE 
C 

I  a  HCPOSN 


400  CONTINUE 


1*1-1 

IF  (I.LE.O)  RETURN  1 

SSS  *  0 1 ST ( HCPOSN , I , HRXYZ ) 

DO  410  X*1 , NTAU 
XI (K)*TAU(K) 

V(K)*FAC<X)*HRVLFT*FLC(K) 

410  CONTINUE 

NTERMS*NTAU 

CALL  AGINGtHRAGEU)) 

CALL  FNOLYR(HRXYZ( I ,3), *557) 

557  CALL  AIR(HRXYZ<!,3)) 

PMAX  *  0.0 
PMIN  *  1CC.0 
DO  420  X*1 ,NTERMS 

V(X)*V(X)*HRPFAC( I  )/2.0 
PMAX*AMAX1(PMAX,V(K}) 

PMIN*AMIN1(PMIN,V(X5> 

420  CONTINUE 

HAXOP1  »  AMAX1 (ABS(PMIN) , ABS(PMAX) ) 

DOPP1  ■  0 

IF  (DOPP1 .EQ.0.0)  00PP1  *  MAXOP1 

CPREF*ODPP1/1 . 40/PRS*2 . 0*0 . 001 
YREF=SSS*SSS/REAL(RRCURV)/2. 

YSTAR*<0..  1**<4./5.  )/0.39)**4*(0.60*CPREF*YREF**0.25* 
♦  REAL(RRCURV) )**(4 ./5. ) 

XSTAR=*S<JRT  ( 2 . 0*REAL  C  RRCURV )*Y$TAR  ) 

IF  (SSS.LT.XSTAR)  GOTO  400 

PFOCUS=PMAX* SORT ( SSS /XSTAR  3 

PMAXP  «  PFOCUS 

PSIG  *  0.05*<PMAX-PMIN) 

XMIN  s  NTERMS 
XMAX  s  1 

DO  810  III  *  1, NTERMS 

IF  (A8S(V( III)). GE. PSIG)  THEN 
XMIN  a  MINOCKMIN , 1 1 1 J 
XMAX  *  MAXOCXMAX, 1 1 1+25 
END  IF 

810  CONTINUE 

NX  =  XMAX  -  XMIN  +  1 

X  *  0 

XSHFT  =  0.0 


DO  300  111  >  KMIN.KMAX 
K  *  K  *  1 

XXT(K)  *  (XlI(IlI+1)-XlI<KMIN+1)*XSHFT)/0.3048 
PPT(K)  *  VI (11 1+1 )/47.8803 
800  CONTINUE 

SREF  a  SSS/0.3048 
RRC  *  RRCURV/0.3048 
CCT  *  C/0. 3048 
C 

C-  PRS  IN  MB  TO  PSF 
C 

PRST  *  PRS/0 . 478803E -01 
C 

NSIG  a  NX 

C 

C-  SELECT  THE  PROPER  OVERPRESSURE  TO  USE 
C 

IF  (HRXYZC 1,3). LE .2GRN0 )  THEN 
MAX OP  a  MAXOPG 
ELSE 

IF  (CXYZ(1  ,3) .GT.2GRN0)  THEN 
IF  (CPGNO.GT.CPREF)  THEN 

CALL  FOCALP (XXT , PPT , NX , SREF , RRC , PRST , CCT , PMX , NS I G ) 
MAX OP  a  PMX*47.8803 
ELSE 

MAX OP  a  MAXOPG 
ENOrF 
ELSE 

CALL  FOCALP(XXT , PPT , NX , SREF , RRC, PRST , CCT , PMX , NSI G) 
MAXOP  =  PMX*47.8803 
END  IF 
END  IF 

MAXOP  a  MAXOP*2.0 

C 

C-  CONVERT  BACK  TO  METRIC 
C 

XSHFT  a  XXT ( 1 ) 

DO  850  III  <  1 , NSIG 

XXT (III)  a  (XXT (III)  ■  XSHFT)«0. 3048*1000. /C 
PPT(III)  *  PPT( 1 1 1 )*47. 8803 
850  CONTINUE 
C 

C-  CALCULATE  THE  CSEL 
C 

CALL  PRTSNG(XXT,PPT,NSIG,C) 

CALL  CALSEL(PPT, XXT, NSIG, CSEL) 

9000  FORMAT ( 1  HI ) 


RETURN 

END 


c 

C  FUNCTION:  DIST 

Z  PROGRAMMER:  PHILIP  J.  DAY 
C  XONTECH  INC. 

C  88N  LABORATORIES 

C  DATE:  DECEMBER  18,  1986 

C 

C  PURPOSE:  TO  COMPUTE  THE  DISTANCE  BETWEEN  TWO  POINTS  IN  SPACE 

C 

C 

FUNCTION  DIST(I , J,RAY) 

REAL  RAY(200,3),TMP 
INTEGER  I,J 

TMP  *  0.0 

DO  100  K  »  1,3 

TMP  a  TMP  ♦  C RAY < I  ,  K)  •  RAY(J,10)**2 
100  CONTINUE 

DIST  *  SORT (TMP) 

RETURN 

END 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


FUNCTION: 

PROGRAMMER: 


DATE: 


INTERP 

PHILIP  J.  DAY 
XONTECH  INC. 

BBN  LABORATORIES 
DECEMBER  18,  1986 


PURPOSE:  TO  DO  A  LINEAR  INTERPOLATION  BETWEEN  TWO  POINTS 


FUNCTION  INTERP(P1,P2,Z1,Z2,ZG) 


REAL  PI ,P2,Z1 ,Z2,ZG 


INTERP  =  (PI  •  P2)/(Z1  -  Z2)*(ZG-Z1)  ♦  PI 


J 


return 


c 

. . 

c 

C  SUBROUTINE:  CURVE 

C  PROGRAMMER:  TAKEN  FROM  THE  F0800M  ROUTINES 

C 

C 

SUBROUTINE  CURVE  (XI ,X2,X3,RRR,RRRR) 

C  THIS  SUBROUTINE  FITS  A  CIRCLE  THROUGH  POINTS  X123,  ANO  RETURNS  THE 
C  RADIUS  VECTOR  ANO  CURVATURE  AS  RRR(3)  ANO  RRRR. 

IMPLICIT  DOUBLE  PRECISION  (A-H.O-Z) 

DOUBLE  PRECISION  XI (3) ,X2(3) , X3(3) , RVCC3) ,DELR1(3> ,DELR2(3) 

1 . DELR3C3) ,D£TR,DETRX,DETRY,DETRZ,RRR(3) ,RRRR,X1 J(3) , YI J(3) 

2, Z1 J(3) 

C  T ( ITEC7,*) 'CURVE  1* 

C  WRITE(7,*),X1,X2,X3=,,X1,X2,X3 

XIJ(1)=X1(1)-X3(1> 

Y1J(1)*X1(2)-X3(2) 

Z1J(1)=X1(3)-X3(3) 

XI J<25*X2< 1 > -X3C1 3 
YI  J(2)*X2(2)-X3(2) 

ZI  J(2)=X2(3)-X3(3) 

RVCCl )=0.0 
RVC(2)*0.0 
DO  6002  J*1  3 

RVCC1)»(XKJ)»*2-X3(.J>**2)*.5*RVC(1) 

RVC(2)*(X2( J)**2-X3( J)**2)*.5+RVC(2) 

6002  CONTINUE 

C  UR  I TE ( 7 , * ) 1  CURVE  2' 

DO  6003  1=1,3 

0ELR1 ( I )=X3( I ) *X1 ( I ; 

6003  DELR2C I )*X2< I ) -XI ( I ) 

XI  J(3',=0ELR1  (2)*OELR2(3) -DELR1  (3)*0ELR2(2) 

YI J(3)=0ELR1 (3)*OELR2(1 )-DELR1 (1 >*DELR2(3) 

ZI J(3)=0ELR1 (1 )*0ELR2(2)-DELR1 (2)*DELR2(1 ) 

RVC(3)=X1 (1 )*XI J(3)+X1 (2)*YI J(3)+X1(3)*ZI J(3) 

DETR  *XIJ(1)*(Y1J(2}*ZIJ(3)-YIJ(3)*ZIJC2))+YIJ(1)*(XIJ(3)*ZIJ(2)- 
1XIJU>*ZIJC3)WIJC1)*<XIJ(2)*Y1J(3)-YIJ(2)*XIJ(3)) 

DETRX=RVC( 1 )*(YI J(2)*ZIJ(3)-YI J(3)*Z1 JC2) )+YI J( 1 )*(RVC(3)*ZI J(2)- 
1RVC(2)*ZI J(3) )+ZI J(1 )*(RVC(2)*YI J(3)- YI J(2)*RVCC3) ) 
DETRY=XIJ(1)*(RVC(2)*ZIJ(3)-RVC(3)*ZIJC2))+RVC(1)*(XIJ(3)*ZIJ(2)- 
1X1 J(2)*Z1 J(3))+ZI J( 1 )*(XI J(2)*RVC(3)-RVC(2)*X1 J(3) ) 

DETRZ=XI J(1 )*(YI J(2)*RVC(3)- YI J(3)*RVCC2) )+YI J( 1 )*(XIJ(3)*RVC(2)- 
1X1 J(2)*RVC(3) )+RVC( 1 )*(XIJ(2)*YIJ(3)-YIJ(2)*XIJ(3)) 

C  UE  NOW  HAVE  THE  CENTER  RRR  ANO  RADIUS  RRRR  OF  THE  FITTED  CIRCLE: 

C  UR  I  TEC 7,*) 'OETR.DETRX, DETRY,DETRZ= 1 ,DETR,DETRX,DETRY,DETRZ 

RRR(1)=0ETRX/DETR 
RRR(2)=0ETRY/DETR 
RRR(3)=0ETRZ/DETR 
C  URITE(7;*) ‘CURVE  3' 

C  NOTE  THAT  XI  OR  X3  UOULD  UORK  EQUALLY  UELL  IN  THE  FOLLOWING  LINE 
RRRR=$QRT ( (RRR( 1 ) • X2( 1 ) )**2*(RRR(2) - XH( 2 )  )**2+(RRR (3 ) - 
1X2(3)  )**2) 


C  WRITE(7,«) ‘CURVE  4' 

RETURN 
END 


c 

c 

c 

SUBROUT I  ME  FOCALPCXX , PP , MX , SRE  f , R , PO , AO , PMAX , NS 1 G ) 

C 

C 

C  THIS  SUBROUTINE  APPLIES  GILL  AND  SEEBASS'  FOCUSED  SHOCK  WAVE  SOL- 
C  UTION  TO  EACH  SHOCK  IN  A  SONIC  BOOM  AT  A  CAUSTIC.  IT  FIRST  CONVERTS 

C  THE  INPUT  SIGNATURE  FROM  VALUES  PP  AT  ARBITRARILY  SPACED  XX  TO  100 

C  EVENLY  SPACED  POINTS.  PRESSURE  POSITIONS  ARE  DIDDLED  SLIGHTLY,  BUT 
C  CO  CHORE  THAN  HALF  OF  ONE  PERCENT  OF  THE  SIGNATURE  LENGTH.  THE  FOCUS 

C  SOLUTION  IS  APPLIED  TO  EACH  SHOCK.  THE  PUBLISHED  SIGNATURE  IS 

C  LINEARLY  EXTRAPOLATED  ‘TIL  ZERO,  SPACE  PERMITTING.  SPACE  NOT  PERMIT- 
C  TING,  FOCUS  SOLUTIONS  ARE  CARRIED  OUT  TO  THE  MIDPOINTS  BETWEEN 
C  SUCCESSIVE  SHOCKS.  CURRENTLY,  A  MESSAGE  IS  PRINTED  OUT  IDENTIFYING 
C  SUCH  COMPUTATIONAL  DISCONTINUITIES;  SOME  TYPE  OF  SMOOTHING  MUST  BE 
C  ADDED. 

REAL  XX(504),PP<504) 

DIMENSION  IDP(50) ,PSH(50), FPOSC21 ) , FNEGC21 ) 

DATA  FNEG/2.38, 1.19, 0.59, 0.55, 0.52, 0.50, 0.48, 0.45, 0.43, 0.42, 0.41, 
10.39,0.36,0.35,0.34,0.33,0.32,0.31,0.30,0.29,0.28/ 

OATA  FPOS/2. 78, 1.75, 1.30, 1.01, 0.83, 0.70, 0.60, 0.54, 0.48, 0.43, 0.40, 
10.36,0.31,0.30,0.27,0.25,0.22,0.20,0.16,0.13,0.10/ 

C  WRITEC  7,900) 

900  FORMAT (1  HI) 

C  FIRST  MAJOR  OPERATION  IS  TO  RE-DISTRJSUTE  THE  SIGNATURE.  IF  THERE  IS 
C  NO  LEADING  SIGNATURE,  IT  STARTS  AT  THE  HEAD  OF  THE  ARRAY. 

JMOVE*0 

C  IF  THERE  IS  A  LEADING  SHOCK,  LEAVE  20  BLANKS  AT  THE  START 
IF((XX(2)-XX(1)).LE.XX(2)*1.0E-05)  JMOVE=20 
J*0 

NXX-NX- 1 

C  THE  FOLLOWING  LOOP  LOOKS  FOR  SHOCKS,  SAVES  THEIR  VALUE,  AND  MARKS  THE 
C  POSITION  ON  THE  INPUT  ARRAYS  (POSITION  *  SECOND  ASSOCIATED  MESH  POINT) 
DO  1  1*1, NXX 
AD AO AO  *  XXC 1*1 )  -  XX(I) 

0 AD ADA  *  XX< 1+1 )*1 .0E-05 

I F< <XXC  1*1  )-XX(I ))  .GT.XXO+1  )*1  .QE-05)  GO  TO  1 
J*J+1 

IDP( J)*I+1 

PSH< J)*ABS(PP( 1+1 )-PP(I ) ) 

1  CONTINUE 
MSH*J 

C  WE  NOW  KNOW  THERE  ARE  NSH  SHOCKS,  AT  IDPO  WITH  JUMPS  PSHO 
C  THE  NEW  SIGNATURE  WILL  HAVE  100  INTERVALS  (101  POINTS),  PLUS  DOUBLED 
C  POINTS  FOR  EACH  SHOCK,  PLUS  THE  ALLOWED  SPACE  AT  THE  BEGINNING. 

NS1 G*101*NSH*JMOVE 
XDEL=(XX(NX)-XX(1))/(100. ) 

C  THE  FOLLOWING  IS  a  LOOP  (ENOING  JUST  ABOVE  LABEL  7)  WHICH  RUNS  I  FROM 
C  1  TO  NX  (SIZE  OF  INPUT  SIGNATURE),  WITH  BACKWARD -RUNNING  INOEX  INO 
C  GOING  FROM  NX  TO  1.  (IND  HAS  THIS  ROLE  OVER  THE  TOP  HALF  OF  THE  LOOP; 


C  IT  IS  USED  AS  A  LOCAL  POINTER  AFTER  LABEL  2.)  THIS  STRUCTURE,  RATHER 
C  THAN  A  DO,  IS  USED  BECAUSE 
C  I  AND  INO  ARE  DOUBLE-BUMPED  AT  SHOCKS. 

1*0 

6  1*1+1 
IN0=NX- 1+1 

C  SET  SHOCK  FLAG.  NOTE  THAT  J  IS  THE  LAST  SHOCK;  IT  WILL  BE  DECREMENTED 
C  AS  EACH  IS  HANDLED. 

ISH*1 

I F( I0P( J ) .EO. IND )  !SH*2 

C  MOVE  INPUT  POINT  TO  NEAREST  ROUNDED- FORWARD  POSITION  ON  NEW  ARRAY. 

C  NOTE  THAT  INPUT  ARRAY  SHOULD  HAVE  NO  MORE  THAN  100  POINTS,  SO  THAT  BY 
C  WORKING  FROM  THE  REAR  OF  AN  ARRAY  WITH  MORE  THAN  100  POINTS,  WE  WILL 
C  CERTAINLY  NOT  OVERWRITE  THE  FIRST  POINT.  OVERWRITING  CAN  OCCUR  ONLY 
C  IF  TWO  ORIGINAL  POINTS  ARE  LESS  THAN  XDEL  APART;  THIS  IS  OK  BECAUSE 
C  OUR  ROUNDING-DOWN-TO-THE-100- INTERVAL  ALGORITHM  DOES  NOT  SUPPORT  THAT 
C  RESOLUTION. 

H*IF1X(aX( JND)/XOEL)+J+JMOVE+1 
XX(N)*XX( INO ) 

PP(N)*PP(IN0) 

C  I  LOU  POINTS  TO  MESH  POINT  JUST  ABOVE  THE  ONE  WE  JUST  FILLED;  THERE 
C  USUALLY  WILL  BE  SOME  EMPTIES  TO  BE  FILLED,  SINCE  GENERALLY  INPUT 
C  POINTS  ARE  SPACED  MUCH  GREATER  THAN  XDEL 
ILOW*N+1 
GO  TO  (2,3), 1SH 

C  FOR  A  SHOCK,  WE  MOVE  THE  UPSTREAM  POINT  AS  WELL  AND  RE -BUMP 
C  THE  POINTERS 

3  XX(N- 1 )*XX( INO- 1 ) 

PP(N- 1 )*PP( IND- 1 ) 

IDP( J  )=N 
J*J-1 
1*1+1 

2  IF(INO.EO.NX)  GO  TO  4 

C  IND  NOW  POINTS  TO  THE  CURRENT  POINT  (DOWNSTREAM  POINT  OF  SHOCK, 

C  IF  THERE  IS  ONE) 

IND*ILOW- 1 

C  SET  UP  PROPORIONALITIES  FOR  LINEAR  FILL-IN  BETWEEN  THIS  NEW  POINT 
C  AND  LAST  ONE 
C 

C-  BRANCH  TO  AVI 00  ABEND 

IF  (1HGH.LT. ILOW)  GOTO  4 

XDELT*(XX( IHGH+1 ) -XX( IND ))/FL0AT( IHGH- I LOW+2) 

POELT  *<PP( I HGH+1 ) -PP( INO )) /FLOAT ( 1 HGH- 1 LOW+2) 

DO  5  I0X*IL0W, IHGH 
XX( IDX)*XX( IDX- 1 )+X0ELT 
5  PP(IDX)*PP(IDX-1)+POELT 
A  I HGH=I LOW- 2 

C  IHGH  POINTS  TO  UPSTREAM  OF  CURRENT  POINT;  NEXT  PASS  THROUGH,  IT  WILL 
C  CORRESPOND  TO  UPSTRAM  OF  LAST  POINT. 

IFOSH.E0.2)  I  HGH=I HGH  - 1 
IF(I.EQ.NX)  GO  TO  7 
GO  TO  6 
7  CONTINUE 


c 

C  SIGNATURE  RE -DISTRIBUTED,  NOW  APPLY  G-S  SOLUTION  TO  SHOCKS. 

P1*0. 

FF«1. 

P11*0. 

C  START  OF  MAIN  LOOP,  CYCLING  THROUGH  SHOCKS  STARTING  AT  FRONT. 

DO  10  J«1,NSH 
IN0X*IDP(J) 

P11*P11*FF*(Pf  wNOX-1)-P1) 

CPREF*2.*PSH(J)/1 ,4/PO 
YREF«SREF»SREF/2./R 

C  FF  AND  FL  ARE  AMPLITUDE  AND  LENGTH  SCALE  FACTORS;  SEE  UR  7W 
C  EQUATIONS  62  AND  63 

C******NEED  TO  MAKE  SURE  FL  CORRESPONDS  TO  LENGTH  COORDINATE  ALONG 
C  RAY;  IT  ISN'T  RIGHT  FOR  GROUND  COORDINATE  BLUNDER  ABOVE****-****'*”' 
FF*0.74*(YREF/1 .2/CPREF/R)**0.2 
FL*(12.*CPR£F*(YREF**0.25)*(R/2. )**(7./12. ))**1 .2 
P1*PP( INDX- 1 ) 

C  APPLY  G-S  SOLUTION  TO  SHOCK-  POINT 
PP(IN0X-1)=FF*PSH(J)*FNEG(1)*P11 
IF(J.GT.1)G0  TO  20 
IF(JMOVE.EQ.O)GO  TO  26 

C  FOR  LEADING  SHOCK,  APPLY  G-S  UPSTREAM  ELEMENT  WITHOUT  SCALING; 

C  XX  VALUES  (NOT  SPACED  XOEL)  AS  WELL  AS  PP  VALUES  ARE  CREATED 
C  IN  THE  20  POINTS  ADDED  FOR  THIS  PURPOSE 
DO  25  11*1,20 
XX( 1 1 )*FLQAT (11-21 )*FL/10. 

25  PP( I I )*f F»(PSH( 1 >*FNEG(22 • 1 1 ) -PI )*P1 1 
C  WE'RE  DONE  WITH  UPSTREAM  PART  HERE,  SO... 

GO  TO  31 

26  I LNG* I NOX -  2 

C  FIRST  SHOCK,  BUT  NOT  LEADING.  NOTE  HOW  MANY  POINTS  ARE  AHEAD  OF  THIS 
C  SHOCK,  THEN  GO  TO  UPSTREAM  G-S  APPLYER,  WITHOUT  WORRYING  ABOUT 
C  MID-POINT  TO  SHOCK  AHEAO  (SINCE  THERE  ISN'T  ANY)... 

GO  TO  32 

C  BEGIN  GENERAL  CASE  OF  APPLYING  UPSTREAM  G-S  SOLUTION  WHEN  THERE  IS  A 
C  SHOCK  AHEAO  OF  CURRENT  ONE.  FIRST  FIND  MID-POINT,  THEN  SET  ILNG  TO 
C  THE  NUMBER  OF  POINTS  JUST  WITHIN  THE  HALF-DISTANCE. 

20  JINDX*IDP( J- 1 ) 

XINT*(XX( INOX) -XX( JINOX) )/2. 

I LNG*0 

DO  21  II  *1,100 

I F(XX( INOX- 1 1 • 1 ) .LT.XX( 1N0X- 1)-X1NT)G0  TO  22 

21  I LNG* I LNG+ 1 

22  CONTINUE 

C  LET  HIM  KNOW  WHERE  THE  BREAK  IS  BETWIXT  THESE  TWO  SHOCKS 

200  F0RMAT(lH0,48HP0SSIBLE  INVALID  PRESSURE  CORRECTION  FROM  SHOCK  ,12, 
18H  AT  X  =  , F10.2) 

C  HOW  APPLY  THE  UPSTREAM  SOLUTION,  GOING  TO  EITHER  F HE  MID  POINT  ;GEN - 
C  ERAL  CASE)  OR  THE  FRONT  ( F I RST - BUT  -  NOT  -  LEAD  I NG  SHOCK  CASE) 

C  THERE  ARE  THREE  ALGORITHMS  BELOW: 

C  •  UP  *0  LAB  40,  WHERE  FNEG  TABLE  IS  OVER  IRREGULAR  X/L  INTERVALS, 

C  SO  THERE  IS  A  SEPERATE  FORMULA  FOR  EACH 
C  -  FROM  LABEL  40  UP  TO  41,  WHERE  X/L  *0.1 


C  -  LABEL  41  ONWARD,  WHERE  A  LINEAR  EXTRAPOLATION  FORMULA  APPLIES. 

32  DO  30  1 1*1 , 1LNG 

XDIST*<XX<INOX-1)*XX(!NOX*iI*1))«10./FL 
!N0N*IFIX<XDIST)f1 
I F( INDN.GT ,2)G0  TO  40 
GO  TO  (50, 60), INON 
50  IF(XDIST.GT.0.3)GO  TO  55 

PP( 1N0X-1 - 1 1 )*(PSH<  J)*(FNEG(1  )-*(2.21 • FNEG(1 ))/0.3*XDIST)*PP( INDX- 
t I I - 1 > - PI )*FF+P1 1 
GO  TO  30 

55  PPONDX*  1  •  1 1  >*(PSH( J)*(2.21+(FNEG<2)*2.21  )/0.7*(XD!ST-0.3))+ 
1PPONOX* 1 1 -1 )-P1 )*FF+P11 
GO  TO  30 

60  1F(XDIST.GT.1.S)G0  TO  65 

PPONDX  - 1 • 1 1 )*(PSH( J)*(FN£G(2)+(0.6- FNEG(2))/0.8*(XDIST- 1 .  ))♦ 
1PPONDX- 1  •  1 1  )-P1)*FF+P11 
GO  TO  30 

65  PPONDX- 1  - 1 1 )*(PSH( J )*(0.6»(FNEG(3) -0.60)/0.2*(XDIST ■ 1 .8) )♦ 

1PP( INDX- 1 • 1 1 )-P1 )*FF+P1 1 
GO  TO  30 

40  IF(XDIST.GE.20.)GO  TO  41 

PP( INOX* 1 -II )*(PSH( J )*(  FNEG{ lN0N)+<  FNEG( 1NDN+1 ) • FNEG( INON))* 

1 (XD I ST* FLOAT ( INON- 1 ) ) )*PP( INDX- 1- l 1 ) *P1 )*FF*P1 1 
GO  TO  30 

41  FNGG*0.28-0.01«(XDIST-20.) 

I FCFNGG.LT.O. )FNGG«0. 

PP( INDX- 1 • 1 1 )*(PSH< J)«FNGG*PP{ INDX- 1 • 1 1 ) -PI )«FF*P1 1 

30  CONTINUE 
C 

C  DOWNSTREAM  G*S  SOLUTION  IS  NOW  APPLIED  FOLLOWING  THE  SHOCK.  LOGIC 
C  IS  SIMILAR  TO  ABOVE,  EXCEPT  UE  NOW  WORRY  ABOUT  THE  STATUS  TO  THE 
C  REAR,  I.E.  HOW  FAR  TO  THE  NEXT  SHOCK  BACK  (IF  ANY),  IS  THE  LAST  SHOCK 
C  AT  THE  END  OF  THE  SIGNATURE,  ETC.  THE  APPLICATION  OF  FPOS  IS  A  BIT 
C  SIMPLER,  SINCE  THE  FPOS  ARRAY  IS  ALL  ON  A  UNIFORM  X/L  *  0.1  MESH. 

C  THERE  ARE  THUS  ONLY  A  SINGLE  INTERPOLATION  FORMULA,  PLUS  EXTRAPOL 
C  AT  I  ON  BEYOND  THE  TABLE. 

31  PP( IN0X)*(PSH( J)*FPOS( 1 )+PP( 1 NOX) *P1 )*FF+P1 1 
IF(J.LT.NSH)GO  TO  80 
IF(IDP(J).LT.NSIG)GO  TO  81 

OO  70  11*1,20 

XX(NSIG+I I )*XX(NSIG)*FLOAT ( 1 1 )*FL/10. 

70  PP(NSIG+! I )*<PSH(NSH)*FPOS(I 1+1 )*P1 )*FF*P1 1 
NSIG=NSIG+20 
GO  TO  95 

81  ILNG*NSIG- IDP(NSH) 

GO  TO  82 

80  J INDX=!0P( J*1 ) 

XI  NT  *(XX( J INDX) -XX( INOX) )/2 . 

I LNG*0 

00  83  11=1,100 

IF((XX(INOX)+XINT).LT.XX(INOX*in)GO  TO  84 

83  ILNG=ILNG+1 

84  CONTINUE 

C  WR 1 TE<  7, 200) J ,XX( I N0X*I LNG) 


82  DO  90  11*1, ILNG 

XDIST*(XX( INDX+I I )  -XXUNDX))*10./FL 
IF<XD1ST.G£.20.)GO  TO  91 
INOP*I FIX(XDIST)+1 

PPONDX+I I )*<PSH(  J)*(FP0SdNDP)*<FP0SdNDP*1 )-  FP0SONDP))*(XD!ST • 
1FLOAT< INDP- 1 ) ))+PP( INDX+II 5 -PI )*FF+P1 1 
GO  TO  90 

91  FPSS*Q.10-0.03*(XOIST-2Q.) 

IF(FPSS.lT.O. )FPSS*0. 

PP< INOX+I I )*(PSH(  J)*FPS$+PPUNDX+t  I  )-P1 )*FF+P1 1 
90  CONTINUE 
10  CONTINUE 

C  ALL  DONE.  PRINT  SIGNATURE  AND  GO  HOME 
NSIG  *  NS1G  -  1 
95  CONTINUE 
C  95  URITEC  7,300) 

300  FORMATdHO,  1 1X,  18HF0CUSSED  SIGNATURE) 

T FAC* 1000. /AO 

C  URITE(  7,400)<XX<I)*TFAC,PP(I), 1*1, NSIG) 

400  FORMATdHO,  (12X.7HT,  MSEC, 14X ,6HP,  PSF)///  (F20.2, F20.3) ) 

C  PMAX  TO  SUMMARY  FILE 
PMAX*PP(1) 

DO  500  I*2,NSIG 

PMAX*AMAX  1  {  PMAX ,  PP  ( I  )  ) 

500  CONTINUE 

510  FORMAT ( 1  PMAX<FOC)*',F10.3) 

RETURN 

ENO 


c 

C  SUBROUTINE:  GETDLT 

C  PROGRAMMER:  PHILIP  J.  OAT 

C  XOMTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  DECEMBER  29,  1986 

C 

C  PURPOSE:  TO  GET  THE  DELTA  INCRIMENT  FOR  THE  PHI  ANGLES  IN  A  CAU 

C  GROUND  1NTERCECTION. 

C 

SUBROUTINE  GETDLT (PHIO.PHI ,NPH1, DELTA) 

REAL  PHIO.PHI (400) .DELTA 
INTEGER  NPHI 
C 

C-  FIND  THE  TWO  ANGLES  PHIO  IS  BETWEEN  AND  TAKE  1/10  OF  THEIR  DIFFERENC 
C 

DO  100  I  =  1 .NPHI • 1 

IF  (PHIO. GE.PHI(I). AND. PHIO. LE.PHKI+1))  THEN 
DELTA  *  ABS(PH!<I*1)  •  PHt(I))/10.0 
RETURN 
ENOIF 

100  CONTINUE 
C 

C-  SET  DEFAULT  VALUE  FOR  DELTA 
C 

DELTA  *  0.5 

RETURN 

END 


c 

C  SUBROUTINE:  FINDT 

C  PROGRAMMER:  PHILIP  J.  DAY 

C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  MARCH  6,  1987 

C 

C  PURPOSE:  TO  FIND  A  POINT  ON  A  RAY  AT  TIME  T. 

C 

C 

SUBROUTINE  FINOT(N,*) 

COMMON  /CAUSTC/  NUMC, TRACE, CT(360) , CPHI (360) , CXYZ(360,3) 

REAL  CXYZ 
LOGICAL  TRACE 

COMMON  /RPOSN/  NPTR , COPSN , RTC200) , RXYZ(200,3) ,RAGE{200) , 

♦  RPF  ACT  (  200  ),RVU  FT,  REMEM 

REAL  RT , RXY2 , RAGE , RPF ACT , RVL I  FT 

INTEGER  NPTR, COPSN 

LOGICAL  REMEM 

COMMON  /HRPOSN/  HNPTR , HCPOSN.HRT (200) , HRXYZ < 200,3 ) , 

♦  HRAGE { 200 ) , HRPFAC ( 200 ), HRVL  FT , HREMEM 

REAL  HRT , HRXYZ , HRAGE , HRPFAC , HRVL  FT 

INTEGER  HNPTR, HCPOSN 
LOGICAL  HREMEM 
C 

C-  RESET  THE  THE  ORIGION 
C 

IF  (N.EQ.1)  THEN 
CT(1)  ■  HRT (HCPOSN ) 

CXYZC1 , 1 )  «  HRXYZCHCPOSN.I) 

CXYZO  ,2)  «  HRXYZCHCPOSN.2) 

CXYZO, 3)  *  HRXYZ  (HCPOSN,  3) 

RETURN 
END  IF 

IF  (CT(I).GT.CT(N))  THEN 
00  100  I  «  2, NPTR 

IF  (HRT(I ) .GE.CT(N) )  THEN 
DO  110  J  *  1,3 

CXYZO, J)  *  HRXYZ(I-I.J)  ♦  ( HRXYZ ( I , J) •  HRXYZ ( I  •  1 ,  J ) )* 

♦  (CT(N)  -  HRT( I •!))/( HRT( I )  •  HRT(I-I)) 
CT(1)  s  CT(N) 

110  CONTINUE 

IF  (N.GT.2)  RETURN  1 
RETURN 
END  IF 

100  CONTINUE 

ELSEIF  (CT(N).GT.CT(D)  THEN 


I 


DO  200  t  *  2.NPTR 

IF  (RT(I).GE.CTO))  THEM 
DO  210  J  »  1,3 

CXYZCN.J)  »  RXrZ(I-1,J)  ♦  (RXYZ(I,J)-RXYZ(I-1,J»* 

♦  (CTO)  -  RT { 1 •  1))/(RT( l)  •  RT( I • 1 ) ) 

CT(M)  *  CT<1) 

210  CONTINUE 

RETURN 
END  IF 

200  CONTINUE  J 

END  IF 


C 


RETURN 


ADD  NAME  *SON I CSOM 


r 
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MOO I F 1 ED  TRAPS  CflOE  FOR  USE  WITH  BOOM MAP  AND  FOBOOH  PROGRAMS 
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T.R.A.P.S.  •  SONIC  BOM  MODELING  PROGRAM  *** 
•**  T. RACING  R.AYS  AND  A.GING  P.RESSURE  SIGNATURES  *" 
***  (SEE  NOAA  TECHNICAL  MEMORANDUM  ERL  ARL-87) 

******************************************************************** 


**'  DR.  ALBION  0.  TAYLOR,  *** 
**•  NOAA/A1R  RESOURCES  LABORATORIES  R/E/AR  «• 
***  RM.  921,  GRAMAX  BUILDING  *** 
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***  SILVER  SPRING,  MO  20910  •" 
*************** ******************************** 

*"  JULY,  1980  *** 
*********************************************** 
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C./  ADO  NAME*8LKDATA 

C 

BLOCK  DATA  TRPRAY 
C 
C 

C  COMMON  BLOCKS 
C 

COMMON  /PUN ITS/  PTA8L , TTA8L , HTABL , STABL.TIMTAS, LTABL , FTABL 
CHARACTER'S  PTABL(6) ,TTABL(4) ,HTABL(6> .STABLC9) ,TIMTAB(2),LTABL(6) 
CHARACTER'S  FTABL (5) 


COMMON  /CPUNIT/  CPTABL, CTTABL, CHTABL, CSTABL, CLTABL, CFTABL, 
ATMPOT , ACPOT 

REAL  CPTABL (6) , CTTABL (2, 4), CHTABL (6) , CSTABL (9) , CLTABL (6) 

REAL  CFTABL(S) 

LOGICAL  ATMPOT (6) , ACPOT (6) 


COMMON  /ATMCON/  REARTH , GO , RSTAR , ROMO , ROGOMO 

COMMON  /ClASES/  CNAMES(30) 

CHARACTER'8  CNAMES 


COWON  /CLASSS/  NRCURV(2,2),TYPRAY(3,2,2),DIRECT,LDFT,UP,DOWN 
LOGICAL  TYPRAY, DIRECT, LOFT, UP, DOWN 

C  OEFAULT  ON  HEIGHT  «  GEOPOTENTIAL(ATMOSPHERE) ,  GEOMETRIC! AIRCRAFT) 

C  INTERNAL  PROGRAM  UNITS  HEIGHT  GEOPOTENTIAL  METERS(ATMOSPHERE) , 

C  GEOMETRIC  METERS  ALL  OTHER  HEIGHTS  ANO  LENGTHS,  TEMPERATURE 
C  DEGREES  KELVIN,  PRESSURE  KILOPASCALS  (KPA),  SPEED  METERS  PER  SECOND. 
C  KNOTS  ANO  NAUTICAL  MILE  CONVERSIONS  BASED  ON  THE  INTERNATIONAL 
C  NAUTICAL  MILE  OF  1852.  METERS  EXACTLY  (6076. 1 155FT) ,  AS  ADOPTED 
C  BY  THE  U.S.  IN  1954,  RATHER  THAN  THE  BRITISH  ADMIRALTY  NAUTICAL 
C  MILE  OF  6080  FT.  (1853.1S4METERS)  OR  THE  U.S.  NAUTICAL  MILE  PRIOR 
C  TO  1954  OF  6080.21  FT.  (1853.250METERS) 

DATA  PTABL/'KPA' , 'MS' , 'NSM' , 'PA* , 'PSF 1 , 'PS1 ' / 

DATA  CPTABL/1 . ,0. 1 ,1 .E3, 1 .E3,4.7B803E-2,6.89476/ 

DATA  TTABL/'C','F','K','R'/ 

DATA  CTTABL/  1., 273. 150,  1.80,459.670,  1.,0.,  1.80,0./ 

DATA  HTABL/ 1  FT 1 , ' GMFT 1 , ' GMM ‘ , 1 GPFT 1 , 1 GPM ' , 'METERS'/ 

DATA  CHTA8L/ .3048 , . 3048 , 1 . , 4 *048, 1 . , 1 ./ 

DATA  ATMPOT / .TRUE. ,2*. FALSE. ,3*. TRUE . / 

DATA  ACPOT/3* . FALSE . , 2* . TRUE . , . FALSE . / 

DATA  STABL/ ' FPS ' , ' FTPS ' , ' KNOTS ' , • KT • , ' KPH • , • MPH ' , ' MPS • , ' NMPH • , 

A  ' SMPH 1 / 

DATA  CSTABL/2*. 3048, 2*. 5144444, .2777778, .4470400, 1 . , .5144444, 

A  .4470400/ 

DATA  TIMTAB/' HHHMSS ' , ' SSSSSSSS ' / 

DATA  LTABL/' FT' , 'KM' , 'METERS' , 'MILES' , ' NMI ' , ' SMI ' / 

DATA  CLTA8L/ .3048, 1E3, 1 . , 1609.344, 1852. , 1609.344/ 

DATA  FTABL/'GM', 'GRAMS', 'KG', 'LB', 'POUNDS'/ 

DATA  CFTABL/2*1E-3,1., 2*. 45359237/ 

C 

C  **********  **«*♦*****-«►*****•*-*•-•.►***♦*  ♦**-*♦***♦-***«* 

C 

C  REARTH»RADIUS  OF  EARTH  FOR  CONVERSION  GEOMETRIC  TO  GEOPOTENTIAL 
C  METERS.  ROMO«RSTAR/NO  ANO  ROGCMO*RSTAR/(GO*MO) 

C  WHERE  RST AR»UN I VERSAL  GAS  CONST ANT*8.31432E3  JOULES  /  (KMOL-DEGK), 

C  G0*9 . 80665M/S£C**2 ,  ANO  MO=MEAN  MOLECULAR  WEIGHT  OF  STANDARD  DRY 

C  AIR  (28.9644  KG/KMOL)  (SEE  U.S.  STANDARD  ATMOSPHERE  1976) 

DATA  REAR TH/6. 35677E6/ , ROGOMO/29 . 271 27/ , RSTAR/8.31432E3/ 

DATA  GO/9. 80665/, ROMO/287. 0531/ 

C 

c 

c 

c 

c  RAY  CLASSES.  G=GROUNO,  M«MID  HEIGHT  (A80UT  50KM)  H=EXTREME 
C  HEIGHT  (100KM  OR  MORE).  RAY  CLASSES  DEFINED  IN  THE  ORDER  IN  WHICH 
C  A  RAY  TOUCHES  ANO  RETURNS  FROM  ANY  OF  THESE  LAYERS.  THUS,  A  GMG 

C  RAY  HAS  REFLECTED  FROM  THE  GROUND,  RECURVED  FROM  THE  MID  LEVEL,  AND 

C  TOUCHED  THE  GROUND  AGAIN.  A  MG  (OR  M)  RAY  ROSE  DIRECTLY  FROM 

C  AIRCRAFT  TO  MID  LAYER  ANO  RECURVED  TO  TOUCH  GROUND. 


DATA  CMAMES/  •  ENDCUSS ' , 1  FULL ' , '  G • , 1 GH • ,  1 GHC  , '  GHGH ' , ' GHGHG ' , 

♦ 1 GHGHGH ' , ' GHGHGHG • , 1 G* ' , ' GMG 1 , • GMGM • , ' GHGMG ' , ' GMGMGM ' , 1 GMGMGMG ' , 
♦•H' , • HG' , ’HGH1 , 'HGHG' , 'HGHGH' , ‘HGHGHG* , ‘M1 , 'MG' , ‘MGM* , 1 HGMG 1 , 

♦ 1 MGMGH 1 , 1 MGMGMG ' , 1  MOPS I NT 1 , ' SHOCKS ' , 1  SUMMARY '/ 

EMO 


c 
c 

Q:rssss3s3s::is3sa3ss:zssz3::sss2::3:sxi23zsasss»3ssss:s3:;sss:s: 
^51ISS3SSSSS35SXS331SS33S3SSSSS13S5133^S1S3£33SSS3335S33S3SS3Z53S: 

C 

C ./  ADO  NAME ’SETUP 

£  **■*******»**«***»*******»***»*»*«•*★»*##**#»#**»#*»****»»»*»*****»*»** 

c 

C  SUBROUTINE  SETUP  INITIALIZES  THE  F- FUNCTIONS  AND  ALL  OF  THE  FLAGE 
C  THAT  THE  T.R.A.P.S  ROUTINES  USE.  IT  CALLS  ATMS  IN  TO  SET  UP  THE 
C  ATMOSPHERE  TABLE. 

C 

SUBROUTINE  SETUP 

COMMON  /ACIONT/  I DENT 
CHARACTER’S  IOENT 

COMMON  /ACUEIG/  ACWT.ACL 

COMMON  /ACSPOT/  TIME ,XR0 , YRO, ZRO , XDOT , YDOT ,ZDOT , A I RSPO , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SI NMU, EX(3,3) , EXSOT (3,3) , GLQAD, HEAD  IN, CLIMB, BANK, 

♦  XDDOT , YDOOT , ZDOOT , XDODOT , TDDDQT , 2DDDQT 

COMMON  /UNITS/  WTUNIT , HTUN1T 
CHARACTER’S  WTUNIT, HTUN IT 

COMMON  /PRINTS/  T1TLE<30) ,TIMLBL 
CHARACTER’4  TITLE 
CHARACTER’8  TIMLBL 

COMMON  /PRINTC/  XTPSIG.CVRTIM 
LOGICAL  CVRTIM 

COMMON  /GROUND/  GLATER , ZGRNO , CGRNO , UGRNO , VGRND , REFLFC 
INTEGER  GLATER 

COMMON  /LYRDEF/NLAYER,GMZA(200) , INDPTH(200> , I NDUNOCZOO) , 

♦LYRPRT ( 200 ) , KLAYER , ZTOP , ZBOT 

INTEGER  INOPTH, INOUNO 
LOGICAL  LYRPRT 

COMMON  /ATMSPH/  GAM,C,U,V,DCOZ,DUOZ,DVDZ,D2CDZ2,D2UDZ2,D2VDZ2,RHO 
REAL  GAM , C , U , V 

COMMON  /PUNITS/  PTABL , TTABL , HTABL , STABL , TIMTAS , LTABL , FTABL 
CHARACTER’S  RYABL<6) , TTABL(A) , HTABL ( 6) , STABL (9) ,TIMTAB(2),LTABLC6) 
CHARACTER’8  FTABL (5 ) 

COMMON  /CPUNIT/  CPTABL , CTTA8L , CHTABL , CSTABL , CLTABL , CFTABL , 

♦  ATMPOT ,ACPOT 

REAL  CPTABL (6), CTTABLI2 ,4), CHTABL (6), CSTABLC9), CLTABL (6) 


REAL 

LOGICAL 


CFTA8LC5) 

ATMPOT ( 6 ) , ACPOT (  6  ) 


C  DEFAULT  ON  HEIGHT  *  GEOPOTENTIAL {ATMOSPHERE),  GEOMETRIC! AIRCRAFT) 

C  INTERNAL  PROGRAM  UNITS  HEIGHT  GEOPOTENTIAL  METERSC ATMOSPHERE) , 

C  GEOMETRIC  METERS  ALL  OTHER  HEIGHTS  AND  LENGTHS,  TEMPERATURE 
C  DEGREES  KELVIN,  PRESSURE  KILOPASCALS  (KPA) ,  SPEED  METERS  PER  SECOND. 
COMMON  /ATMCON/  REARTH , GO, RST AR , ROMO , R0G0M0 

COMMON  /CLASES/  CNAMESOO) 

CHARACTER’S  CNAMES 

COMMON  /CLASSS/  NRCURV(2,2),TYPRAY(3,2,2),DIRECT,LOFT,UP,DOWN 
LOGICAL  TTPRAT, DIRECT, LOFT, UP, DOWN 

C  RAY  CLASSES.  G=GROUND,  M=MI0  HEIGHT  (ABOUT  50KM)  H«EXTREME 
C  HEIGHT  (100KM  OR  MORE).  RAY  CLASSES  DEFINED  IN  THE  ORDER  IN  WHICH 
C  A  RAY  TOUCHES  ANO  RETURNS  FROM  ANY  OF  THESE  LAYERS.  THUS,  A  GMG 

C  RAY  HAS  REFLECTED  FROM  THE  GROUND,  RECURVED  FROM  THE  MID  LEVEL,  AND 

C  TOUCHED  THE  GROUNO  AGAIN.  A  MG  (OR  M)  RAY  ROSE  DIRECTLY  FROM 

C  AIRCRAFT  TO  MIO  LAYER  ANO  RECURVED  TO  TOUCH  GROUND. 

LOGICAL  FND 
INTEGER  KTRNS(29) 

CHARACTER’S  PRTYP<4) 

CHARACTER’S  BUF(9),TPUN1T(3) 

CHARACTER’S  S8UF(9) 

CHARACTER*120  TITLE1 

EQUIVALENCE  (BUF( 1 ) , S8UF(1 ) ) , (TITLE1 , TITLE(1 ) ) 

DATA  KTRNS/ 4,0, 24*  *1,1,3, 2/ 

DATA  PRTYP/'  NO' ,' SUMMARY '  SHOCKS','  FULL'/ 

DATA  TPUN IT/ ' WEI GHT ',' HEIGHT ', • RAYCLASS ' / 

C 

C-  INPUT  FILES 
C 

C  OPEN(5, FILE3 'TITLE ' , STATUS* 'OLD 1 ) 

TITLE1  3  .  BOOM 2  TESTING  . 

C 

C-  OUTPUT  FILES 

C 

C 

C-  TEMPORARY  FILES 
C 

OPEN  <9 , STATUS3 ' SCRATCH ' ) 

C  OPEN<11,STATUS3'SCRATCH') 


C  READ  2  TITLE  CARDS  (1-72  ON  FIRST  CARD,  1-24  ON  2ND) 
C  READ(5, 10)  TITLE 
10  FORMAT (18A4) 

C 

CALL  FFUNCC IDENT , FND ) 

CALL  UN  I T I S(UTUN I T , FTABL , 5 , 1 MUN I T , TPUN I T< 1 ) , 4 ) 


ACWT-ACVIT*CFTABL(IWJN1T) 
BUF  F-ACWT/CFTABL ( l  NUN I T ) 


CALL  UNITIS(HTUNIT,HTA8L,6,1GUNIT,TPUNIT<2),6) 
HEIGHT  *  ZGRND 

HEI GHT-HEIGHT*CHTABL( I GUNI T ) 

C .  CHANGED  FTOM  /  TO  • 

I F (ACPOT ( 1 GUN I T ) )  HE 1 GHT-HE I GHT/ ( 1 . • HEI GHT/REARTH ) 
ZGRND -HEIGHT 

I F (ACPOT ( I GUN I T ) )  HE 1 GHT-HE I GHT/ ( 1 . +HE I GHT/REARTH ) 

HEIGHT-HEIGHT/CHTABL( IGUN1T) 

C .  CHANGED  FTOM  *  TO  / 


C  READ  RAY  TYPES  TO  BE  RECORDED. 

DO  412  K-1,2 
DO  42  L»1 ,2 
DO  41  N-1,3 

TYPRAY(H,K,L)*. FALSE. 

41  CONTINUE 
NRCURV(K,L)--1 

42  CONTINUE 
412  CONTINUE 

KTPSIG-1 
UP-. FALSE. 

DOWN-. FALSE. 

DIRECT-. FALSE. 

LOFT-. FALSE. 

43  CONTINUE 

BUF(1)  *  'G' 

BUF(2)  *  1  1 

00  55  K-1 ,9 

CALL  UNITIS(8UF(K),CNAMES,30,lCUNIT,TPUNIT(3),1) 
IF(LCUNIT.LE.I)  GO  TO  60 
IF(KTRNS(LCUNIT-1))  47,45,50 
45  DIRECT-. TRUE. 

DOWN-. TRUE. 

GO  TO  55 

47  IF(LCUNIT.GE.28)  GO  TO  50 

LOFT-LOFT . OR . (LCUN I T . IE . 14) 

LCUN I T-( LCUN I T -  4 )/2 
KDWNUP-LCUN I T / 6 
KHM=LCUNIT/3-<DWNUP*2 
KMH-2-KHM 

KRCRV-LCUN I T • 3*KHM • 6*KDUNUP 
T YPR AY ( KRCRV+ 1 , KDWNUP* 1 , KMH ) = . TRUE . 

NRCURV( KDUNUP* 1 ,  KMH) -MAXO ( NRCURVC XDUNUP* 1 , KMH ) , KRCR V+ 1 ) 


UPXJP.OR.OOJWNUP.NE.O) 

OOWN«OOWN . OR . ( KDWNUP . EO . 0 ) 

GO  TO  55 

50  KTPSIG*MAX0(ICTPSIG,KTRNS(LCUNtT-1)-1) 

55  CONTINUE 

GO  TO  43 
60  CONTINUE 
DO  75  K*1,2 
00  75  L»1,2 
DO  75  M*1,3 

IF(.NOT.TYPRAY<N,JC,L))  GO  TO  75 
ICTABL*12*(K- 1 )*6*(2-L)+2*M*3 
75  CONTINUE 

IF(KTPSIG.EO.-I)  KTPSIG=3 
CALL  ATMS IN 

CALL  FNOL YR ( ZGRNO , *80 ) 

80  CALL  A1R((2GRN0)) 

CGRN0»C 

UGRN0«U 

VGRNO*V 

DO  888  II  *  1,4 
ZZZ  *  GMZA(II) 

CALL  AIR(ZZZ) 

888  CONTINUE 

OPEN (8 ,  STATUS**  *  SCRATCH 1  ) 

RETURN 

END 
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NAMEsATMSIN 


SUBROUTINE  ATMSIN  CALCULATES  AN  ATMOSPHERIC  TABLE  BASED  ON  THE  STA 
STRATOFIED  ATMOSPHERE.  IT  ALSO  RTAINS  THE  ABILITY  TO  READ  FROM  A  RA 
FILE  AND  A  WIND  FILE.  ****  WARNING  ***•  THE  PROGRAM  HAS  NOT  BEEN  TE 
WITH  ANYTHING  OTHER  THAN  A  STANOARO  ATMOSPHERE  ANO  USE  OF  ANYTHING  E 
COULD  PROOUCE  UNPREDICTABLE  RESULTS. 


SUBROUTINE  ATMSIN 


COMMON  /PTH/  NPTH , PRESS! 97) , TMPMOL (97) , GPHCC97) , GAMMAC97) 
COMMON  /WINDS/  NW1NDS,GPHW(80) ,D1R(80> ,TURN<79> , SPEED(80> 
COMMON  /ATMCON/  REARTH , GO , RSTAR , ROMO , ROGOMO 
COMMON  /GROUND/  GLAYER , ZGRND , CGRND , UGRND , VGRND , REFL FC 
INTEGER  GLAYER 


COMMON  /LYROEF/NLAYER ,GMZA<200) , !NDPTH(200> , INDWNDC200) , 
♦LYRPRT<200) , KLAYER , ZTOP , 2BOT 


INTEGER  INDPTH, INDWND 
LOGICAL  LYRPRT 
REAL  PRIVTLI24) 


LOGICAL  REC 


DATA  PRINTL/-5.E3,0. ,2.E3,4.E3,6,E3,8.E3, 10.E3, 15.E3.20.E3, 
+25.E3,30.E3,35.E3,40.E3,45.E3,5.E4,6.E4,7.E4,8.E4,9.E4,10.E4,11.E4 
+, 12.E4, 13.E4, 1 .E7/ 


ZFROMH(H)*H/<1.  H/REARTH) 


REC  *  .FALSE. 
CALL  PTOHIN 
CALL  WINOIM 


ZPTH»ZFROMH(GPHC(1 )) 
ZWIND*ZFROMH(GPHU(  1 ) ) 

ZM1  »  PRINTU1) 

NLAYER*1 

GMZA(NLAYER)=AMAX1 (ZM1 ,ZPTH,ZWIND) 


OO  2  KPRT*1,24 

I F(PRINTL(KPRT ) ,GT , GMZA( 1 ) )  GO  TO  3 
LPRT=MIN0(KPRT,23) 

2  CONTINUE 


3  DO  4  KPTHsl.NPTH 


2PTH»2FR0MH<GPHC(KPTH>> 

IF(ZPTH.GT.GHZAO))  GO  TO  5 
LPTH*MI NOCKPTH , NPTH  *  1 ) 

4  CONTINUE 

5  1N0PTH<NLAYER)*LPTH 

00  6  KWIN0*1,NWIN0S 

ZWI N0*ZFRCMH ( GPHW<  KW1 NO ) ) 

IF(ZWINO.GT.GMZAO))  GO  TO  7 
LUIN0*NIN0(KW1N0,NV1N0S-1) 

6  CONTINUE 

7  INOUND(NLAYER)*LWINO 

10  KPRTsNINOaPRT+1,24) 

KPTH*NIN0(LPTH+1,NPTH) 

KUIND»NIN0(LUIN0+1,NUINDS) 

ZPRT  *PR I NTL ( KPRT ) 

ZPTH*ZFROMH( GPHC  C KPT H  ) ) 

ZUI ND*ZFROHH(GPHU(KUIND ) ) 

ZLEVEL»AMIN1(ZPRT,ZWIN0,ZPTM) 

I F (ZLEVEL . LE . GMZAC  NLAYER ) . OR . (NLAYER . GE . 200 ) )  GO  TO  200 

NLAYER*NLAYER*1 

IF  CZGRND.EQ. ZLEVEL)  THEN 
GLAYER  *  NLAYER 
REC  *  .TRUE. 

END  IF 

IF  (.NOT. REC.AND.ZGRNO.lt. ZLEVEL)  THEN 
GMZA(NLAYER)  *  ZGRNO 
GLAYER  *  NLAYER 
REC  *  .TRUE. 

ELSE 

GMZA(NLAYER)*ZLEVEL 

ENOIF 

LYRPRT( NLAYER)*. FALSE. 

I F ( GM ZAC  NLAYER ) . LT . ZPRT )  GO  TO  30 
LYRPRT( NLAYER)*. TRUE. 

LPRT*NIN0(KPRT,23) 

30  I F(GMZA(NLAYER).EO.ZPTH)  LPTH=MINO(KPTH,NPTH- 1 ) 

INOPTH( NLAYER )*LPTH 

I F(GMZA( NLAYER ).EQ.ZWINO)  LWIND=HIN0(KW1N0,NUINDS- 1 ) 
INOWNO(NLAYER)rLWIND 
GO  TO  10 

200  LYRPRT(1 )*,TRUE. 

LYRPRT (NLAYER)*. TRUE. 


c 

C ./  ADD  NAME'PTDHIN 

C 

C  SUBROUTINE  PTOHIN  READS  IN  THE  RA08  PILE.  IT  CONVERTS  ALL  DATA  TO 
C  S.2.  UNITS,  INTERPOLATES  DEWPOINT  DATA  AS  NEEDED  AND  CALCULATES  VIRTU 
C  OR  MOLECULAR  SCALE  TEMPERATURES  PROM  THE  TEMPERATURE  AND  DEWPOINT  DAT 
C  AS  APPROPRIATE,  RETURNS  A  TABLE  OP  VIRTUAL  TEMPERATURES,  PRESSURES,  A 
C  NIGHTS. 

C 

SUBROUTINE  PTDHIN 
COMMON  /PRINTS/  TITLE{30) , TIMLBL 
CHARACTERS  TITLE 
CHARACTER'S  TIML8L 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM 

COMMON  /PTH/  NPTH , PRESS ( 97) , TMPMOL  C  97) , GPHCC97) , GAMMA(97) 

C  ••  TMPMOL*  ‘MOLECULAR  SCALE  TEMPERATURE*  *  VIRTUAL  TEMPERATURE 
C  ••  GPH  *  GEOPOTENTIAL  HEIGHT 

REAL  GPH ( 80 ) , TEMPK  <  80  ) , DEWPNT (80) 

REAL  STANHT(21) 

REAL  STANTP(21) 

REAL  STANGM(21) 

COMMON  /PUNITS/  PTABL , TTA8L, HTABL, STABL , TIMTAB, LTABL , PTABL 
CHARACTER'S  PT ABL  <  6 ) , TT A8L ( 4 ) , HTABL C  6 ) , STABL  C  9 ) , T I MTAB  C  2 ) , L  T ABL  C  6 ) 
CHARACTER'8  FTABL(5) 

COMMON  /CPUNIT/  CPTABL.CTTABL, CHTABL , CSTABL , CLTABL .CFTABL, 

♦  ATMPOT,ACPOT 

REAL  CPTABL ( 6 ) , CTTABL (2,4), CHTABL C  6) , CSTABL (9) , CLTABL (6 ) 

REAL  CPTABL (5) 

LOGICAL  ATMPOT ( 6 ) , ACPOT ( 6 ) 

C  DEFAULT  ON  HEIGHT  *  GEOPOTENTIAL (ATMOSPHERE),  GEOMETRIC(AIRCRAPT) 

C  INTERNAL  PROGRAM  UNITS  HEIGHT  GEOPOTENTIAL  METERSC ATMOSPHERE ) , 

C  GEOMETRIC  METERS  ALL  OTHER  HEIGHTS  AND  LENGTHS,  TEMPERATURE 
C  OEGREES  KELVIN,  PRESSURE  KILOPASCALS  (KPA) ,  SPEED  METERS  PER  SECOND. 

CHARACTER'S  ST ANRD, FINISH, BLANK 
CHARACTER'8  TPUNIT<4) 

CHARACTER'8  BUF(4) 

REAL  DUMMY ( 7) ,DEFARY(4) 

COMMON  /WKRAOB/  HMI SS(97) , PMI SS(97) 

LOGICAL  HMISS.PMISS 


LOGICAL  DMISS(SO) .GEOMET , GEOPOT .SOMEHT , TRUE 
LOGICAL  FALSE 

COMMON  /ATMCON/  REARTH, GO, RSTAR , ROMO, ROGOMO 

DATA  STANHT/ - 5E3 , 1 1 E3 , 20E3 , 32E3 , 47E3 , 5 1 E3 , 71 E3 , 84852 . , 8971 6 . , 

+  94572. ,97482. ,99420. , 102326. , 104261 . , 106196. , 107162. , 108129. , 

+  117777., 121627. ,125473. ,130274./ 

DATA  STANTP/320. 65, 216. 65, 216. 65, 228. 65, 270. 65, 270. 65, 214. 65, 

♦  186.95,187.16,189.35,194.28,204.63,213.22,221.65,234.19,242.86, 

♦  254 . 27,397. 09 , 453 . 89 , 5 08 . 05 , S71 . 42/ 

DATA  STANGH/7*1 .401,2*1.402,1.404,1.406,1.408,1.411,1.413, 

♦  1. 416, 1. 417, 1.419, 1.432,1. 436, 1.441, 1.446/ 

DATA  STANRO/' STANDARD'/, FINISH/ ‘END1 /.BLANK/1  •/ 

DATA  TPUN IT/1 PRESSURE', •  TEMP','  DEW  PT.','  HEIGHT'/ 

DATA  OEFARY/4*- 1 .£6/ 

DATA  TRUE/. TRUE. /.FALSE/. FALSE./ 

C  REARTH=RAOIUS  OF  EARTH  FOR  CONVERSION  GEOMETRIC  TO  GEOPOTENTIAL 
C  METERS. 

VAPRS<DUPT)*.6105*£XP(25 .22*(1 . -  273. /DUPT)- 5.31 *ALOG(DUPT/273. )) 
RATM I X ( PRS , DWPT )»0 . 622/ < t PRS/ VAPRS ( DWPT ) ) • 1 . ) 
VlRTMP<TMP,RTMlX)*TMP*(1.+0.61653*RTHtX) 

GHW(RTHIX)*1 .401*0 .+1 .899*RTMIX)/< 1 .♦2.016*RTMIX) 

PRESS< 11*177.68 
PMISS( 1 )*FALSE 
TMPMOL  < 1 )*STANTP( 1 > 

C 

C  READ  TITLE/STANOARO  CARD  AND  INTERPRET 
C 

C  READ <5,5, EN0*200 )  8UF 

C  5  FORMAT (9A8) 

C 

C-  BRANCH  AROUND  TO  SETUP  STANDARD  ATMOSPHEAR 
C 

GOTO  200 

C  CALL  LJUST(8,4,KAR0,SUF) 

CALL  LOKUP<  8 , 1 , STANRO , 8UF ( 1 ) , I STND , *6 , *7) 

6  IF(BUF(1).EO. BLANK)  GO  TO  7 
GO  TO  200 

7  URITE<7,8)  TITLE 
WRITE<7,9)  3UF 

8  FORMAT ( ' 1 ' ,30A4) 

9  FORMAT ( 'O' ,9A8) 

C 

C  READ  UNITS  CARO  AND  INTERPRET 
C 

C  READ(5,5,ENO*200)  8UF 

C  CALL  L JUST (8,4 , KARD , 3UF ) 

CALL  UNITIS(BUF(1),PTABL,6,IPUNIT,TPUNIT(1),2) 

CALL  UNIT! S(BUF(2) , TTABL ,4,1  TUN  I T, TPUN I T (2) , 0) 

CALL  UNITIS(8UF(3), TTABL ,4, 1 DUN  I T , TPUN IT (3) , ITUN IT ) 


IF(ITUNIT.EQ.O)  1TUNIT*10UNIT 
IF(ITUNIT.NE.O)  GO  TO  30 
ITUNIT-1 
IDUNIT»1 

30  CALL  UNIT1S(BUF(4),HTABL,6,I HUN t T , TPUN I T  (  4 ) ,  5  ) 

GEOMET  * . MOT . ATMPOT ( I  HUM I T ) 

C 

C  READ  IN  DATA  VALUES  P-T-D-H.  CONVERT  TO  1MTERMAL  UNITS. 

C  CHECK  FOR  MISSING  VALUES  OF  OEUPOINT  AND  HEIGHT. 

C 

TEMPK( 1 )«STANTP( 1 ) 

HMISS(1)«TRUE 
DMISS(1)»TRUE 
SOME HT a FALSE 
DO  50  N«2,80 

C  READ(10,5,END»55)  KARO 

C  CALL  LJUST<8,4,KAR0,8UF) 

C  READ (5 , S55 , END*55 )  DUMMY 

555  FORMAT (4F8.0) 

DO  556  II  «  1,4 

IF  (DUMMYd  I  ).LE.  -999. )  DUMMY(II)  «  DEFARYCI I  } 

556  CONTINUE 

C  IF<8UF(1).EO. FINISH)  GO  TO  55 

C  CALL  FFA2N<KAR0, 1,8, 4, DUMMY, DEFARY, KERR) 

PRESS ( N )=OUMMY  <  T )*CPTABL ( I PUN l T ) 

TEMPK(N)=(DUMMY(2)+CTTABL(2,ITUNIT))/CTTABL(1,ITUNIT) 
OEWPNT(N)*(DUMMY (3)*CTTA8L(2 , IDUNIT) )/CTTABL< 1 , IDUN I T ) 
GPH ( N )»OUMMY  <  4 )*CHT ABL ( I  HUN I T ) 

I F ( GEOMET )  GPH ( N )»GPH  <  N )/ ( 1 . +GPH ( N )/RE ART  H ) 
TMPMOL(N)»TEMPK(N) 

GPHC(N)*GPH(N) 

OMISS(N)*OEWPNT (N).LT.O. 

PMISS<N)«PRESS<N).LE.O. 

HMISS<N)»GPH(N).LT.-1.E4 

I F(TEMPK(N) .LT .O..OR,(PMISS(N) .AND . HMI SS(N) ) )  GO  TO  65 

IF(HMISS(N).OR.PM!SS(N)}  GO  TO  50 

I F(SOMEHT)  GO  TO  50 

SOMEHT»TRUE 

IPTHTaN 

50  CONTINUE 
N*81 

WRITE(6,51 ) 

51  FORMAT ( 1  P-T-O-H  REAOIMG  TERMINATED  AFTER  7 9  ITEMS.') 

55  NPTH=N-1 

I F(SOMEHT)  GO  TO  70 


60  FORMATC  AT  MO  LEVEL  IS  BOTH  HEIGHT  AND  PRESSURE  GIVEN.  CANNOT  EVA 
♦LUATE  ATMOSPHERIC  PROFILE.  RUN  ABORTED.') 

STOP  650 

65  WRITE(6,67)  BUF 

67  FORMAT ( 1  INSUFFICIENT  DATA  ON  CARO:  "  • ,9A8, <  "  '/•  RUN  ABORTED.') 
STOP  650 

70  CALL  RA08WK(1,!PTHT,-1) 

CALL  RA08WKC I PTHT , NPTH , 1 ) 

C 

C  WORK  DOWN  TO  OBTAIN  VIRTUAL  TEMPERATURES.  BEFORE  TOPMOST  DEW  POINT, 
C  MIXING  RATIO  IS  ZERO.  DEW  POINT  INTERPOLATED  LINEARLY  ACROSS  GAPS 

C  W.R.T.  DRY  GPH,  CONSTANT  BELOW  LOWEST  INPUT  DEW  POINT. 

C 

DO  71  NN«1,NPTH 
N«NPTH-NN*1 

IF  ( .NOT .DMISS(N) )  GO  TO  72 
GAMMA(N)«1 .401 

71  CONTINUE 
GO  TO  80 

72  N2*N 

OOLD*OEWPNT ( N2) 

HOLD-GPHCCN2) 

DO  77  NN»2,N2 
N-N2-NN+2 
DO  73  N3»2,N 
N4-N-N3-M 

IF  (.NOT.DMISS<N4))  GO  TO  74 

73  CONTINUE 
DNEW*OOLD 
GO  TO  75 

74  DNEW*0EWPNT(N4> 

75  HNEW*GPHCCN4) 

M4*N4*1 

DO  76  N5-N4.N 

0*( (GPHC(NS) -  HOLD )*0NEW+( HNEW- GPHCCN5) )*OOLD )/(HNEW- HOLD ) 
RTMIX*RATMIX(PRESS(N5),D) 

GAMMA(N5)»GMW(RTMIX) 

TMPMOL  <  N5 )* V I RTMP ( TEMPK ( N5 ) , R  TM I X ) 

76  CONTINUE 
OOLO“ONEW 
HOLD«HNEW 

77  CONTINUE 
C 

RTMI X*RATM I X<  PRESS( 1 ) , DOLD ) 

GAMMA(1)«GMW(RTMIX) 

TMPMOL ( 1 )«V1 RTHP(TEMPK( 1 ) , RTMIX) 

80  CALL  RAOBWKC 1,1 PTHT, -1) 

CALL  RA08WK(IPTHT,NPTH,1) 

C 

C  PRINT  OUT  WORKED  UP  VALUES  IN  ORIGINAL  UNITS 
C 

WRITE <6, 100)  PT  ABL ( I  PUN  I T ) , TTABL ( I  TUN  I T ) , TT  ABL ( I  DUN  IT), 


♦HT  ABU  I  HUN  1 T  ) ,  HT  ABl  ( I  HUN  I T  ) ,  TTABL  U  TUN  I T ) 

1 00  FORMAT { 1 0 1 , T 1 7, ' TEMPERATURE 1  ,T35, 'HEIGHT1 ,T49, 'VIRTUAL  1 ,T60, 

♦  'SOUMO'/SX, ‘PRESSURE 1 ,T13, 'KINETIC' ,  T21 , ‘OEU  POINT 1 ,T32, 1  INPUT • 

♦  T39, • COMPUTED • , T50 , 1  TEMP . • , T60 , ' SPEED ' /5X , 6A9 , T62 , 1 MPS • ) 

GEOPOT  * . NOT . OEOMET 
00  110  N*2, NPTH 

DUMMY ( 1 ) «PRESS < N ) /CPT ABL  ( I  PUN I T ) 

DUMMY ( 2)«TEMPK ( N )*CTTA8L  < 1 , 1 TUN  I T ) - CTT ABL  ( 2 , 1  TUN  I T ) 

DUMMY  (  3  )«OEWPNT  (  N  )*CTTA8L<  1 , 1  DUN  I T  )  •  CTTASU  2 , 1  DUN  I T  ) 
H1PRNT*GPH(N) 

H2PRNT»GPHC(N) 

IF(GEOPOT)  GO  TO  105 
H1PRNT«H1PRNT/(1 . -H1PRNT/REARTH) 

H2PRNT»H2PRNT/C 1 . - H2PRNT /REARTH) 

105  DUMMY(4)«H1PRNT/CHTABL(IHUN1T) 

DUMMY ( 5 )*H2PRNT /CHTABL ( I  HUN  I T ) 

DUMMY<6)*TMPMOL(N)«CTTABL(1,ITUNIT)-CTTA8L(2,ITUNIT) 

DUMMY ( 7)*SORT  <R0M0*GAMHA( N) *TMPMOL ( N ) ) 

C  CALL  FFN2A(KAR07, 1 , -8, 4 ,7, DUMMY) 

C  I F(HMISS(N) )  KARD7(4)*8LANK 

C  IF  (DMISS(N))  KARD7<3)*8LANK 

C  URITE(7, 107)  KARD7 

C  107  FORMAT (1X.7A9) 

WRITEC7, 107)  DUMMY 
107  FORMAT<1X,7F8.4) 

110  CONTINUE 
GO  TO  300 
C 

C  STANDARD  ATMOSPHERE  BASIS  PREPARATION 
C 

200  GPHCC 1 )*STANHT ( 1 ) 

HMI SS( 1 )*FALSE 
GAMMA ( 1 )«STANGM( 1 ) 

NPTH«1 

C  URITEC6.210) 

210  FORMATCOSTANOARD  ATMOSPHERE  TABLE  SELECTED.') 

C 

C  MERGE  IN  STANOARO  ATMOSPHERE  (1976) 

C 

300  STANLO*GPHC(NPTH)*1000. 

I F< GPHCINPTH ) . GT . STANHT< 21 ) )  RETURN 
OO  310  K*2,21 

I F ( STANLO. LE . STANHT(K) )  GO  TO  320 
310  CONTINUE 
K=21 

320  L2=MIN0(22-K,97hPTK) 

IF(L2.LT.1)  return 
OO  350  1*1, L2 
NL*NPTH*L 


LK*L*«- 1 

GPHC(Nl)*STANHT<UO 
TMP*OL(NL)*STANTP(LIO 
GAMMA(  NL )  >STANGM<  UO 
P*ISS<NL)»TRU£ 
HH!SS(NL)*FALSE 
350  CONTINUE 

CALL  RA08WK ( NPTH , NPTH+L2 , 1 ) 
NPTH«NPTH*L2 

RETURN 

ENO 


c 

c 

Q3SS323S33Sn83IUS»2SSS»SSIS33SSXSSSSSSSaS3S53SSZS333SS3S3S3»3233SSS 

Q3SS33sa33S3S»:SS333333XS3C332S:3333X33S333S:3:3333S33S333S3S3S383S333S 

c 

C ./  AOO  NAME*RA08WK 

C 

C  SUBROUTINE  RAOBUK  IS  CALLED  TO  “WORK  UP  A  RA08";  I.E.,  TO  CALCULAT 
C  FROM  THE  OIVEN  TEMPERATURES  ANO  PRESSURES  THE  “THICKNESS"  (I.E.,  THE 
C  HIGHT  OF  THE  COLUMN  OF  AIR  BETWEEN  EACH  PAIR  OF  PRESSURE  LEVELS)  AND 
C  THEN  CALCULATE  HIGHTS.  CONVERSELY,  IF  GIVEN  THICKNESS,  CALCULATE 
C  PRESSURE  DROP. 

C 

SUBROUTINE  RAOBUK (I LOU, IHIGH, IOIR) 

COMMON  /PTH/  NPTH, PRESS (97) ,TMPMOL(97) , GPHCC97) , GAMMA<97) 

C  ••  TMPMOL*  'MOLECULAR  SCALE  TEMPERATURE'  *  VIRTUAL  TEMPERATURE 
C  ••  GPH  *  GEOPOTENTIAL  HEIGHT 

COMMON  /UKRA08/  HMI SS<97) , PM1 SS(97) 

LOGICAL  HMISS.PM1SS 

COMMON  /ATMCON/  REARTH , GO , RST AR , ROMO , R OGOMO 
C  ROMO-RSTAR/MO  ANO  ROGOMO*RSTAR/(GO*MO) 

C  WHERE  RSTAR*UNI VERSAL  GAS  CONSTANT*8.31432E3  JOULES  /  (KMOL-DEGK) , 

C  G0*9.80665M/SEC**2,  ANO  M0*HEAN  MOLECULAR  WEIGHT  OF  STANDARO  DRY 
C  AIR  (28.9644  KG/KMOL)  (SEE  U.S.  STANDARD  ATMOSPHERE  1976) 

F1S(TAU)*(((TAU/5.*1.)*TAU/4.*1.)«TAU/3.*1.)*TAU/2.f1. 

FI A(TAU)*(EXP(TAU) - 1 . )/TAU 
1F(IL0W.GE. IHIGH)  RETURN 

I D I R* IS1GNC1 , IOIR) 

IF  (IDIR.EQ.O)  RETURN 

K0FSET*0 

IF(IDIR.LT.O)  KOFSET  *  I LOW+ IHIGH 
I  STOP*! HIGH- 1 
DO  9  NN*ILOU, ISTOP 

N*KOFSET  +ISIGN(NN,IDIR) 

T  AU* ALOG( TMPMOL ( N ) /TMPMOL (N+IDIR)) 

I F(ABS(TAU) . GT . . 1 )  GO  TO  2 
FACTOR*TMPMOL(N)*F1S(TAU) 

GO  TO  3 

2  FACTOR*TMPMOL(N)*F1 A(TAU) 

3  I F(PMI SS(N+ID IR) )  GO  TO  5 

TH I CK*ALOG(PRESS(N )/PRESS(N*  ID  I R ) )*FACTOR*ROGOMO 

GPHC(N*IDIR)-GPHC(N)*THICK 

GO  TO  9 

5  PRESS(N+ ID  I R)-PRESS(N)*EXP( (GPHC(N)-GPHC(N+IDIR))/ 

4  ( FACTOR*ROGOMO ) ) 

9  CONTINUE 


RETURN 

END 


c 

c 

C:8SS3S3UnSI33ISSX3H3»X»3  =  SSS3SSS3CSSS3SHX3SXSStS3SSaSS33SS: 


c 

C./  ADD  NAME=WINDIN 

C 

C  SUBROUTINE  WINOIN  READS  IN  THE  WIND  FILE  AND  PROOUCES  A  INTERNAL  T 
C  OF  WIND  SPEEDS,  DIRECTIOS,  AND  "TURNING  RATES". 

SUBROUTINE  WINOIN 
COMMON  /PRINTS/  TITLE(30) , TIMLSL 
CHARACTER*4  TITLE 
CHARACTER'S  TIMLSL 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM 

COMMON  /WINOS/  NWINDS,GPHW(80) ,DIR (80) , TURN<79> , SPEED(80) 

COMMON  /PUNITS/  PTA8L ,TTABL, HTABL, STABL .TIMTAB, LTABL , FTABL 
CHARACTER'S  PTABL(6),TTABL(4) ,HTA8L(6) ,STABL(9) , TIMTABC2) , LTABL (6) 
CHARACTER'8  FTABL<5) 

COMMON  /CPUNIT/  CPTABL , CTTA8L , CHTABL , CSTABL , CLTABL , CFTABL , 

♦  ATMPOT ,ACPOT 

REAL  CPTABL (6) ,CTTABL( 2, 4), CHTABL (6) ,CSTABL (9), CLTABL (6) 

REAL  CFTABL(S) 

LOGICAL  ATMPOT (6) , ACPOT(6) 

C  DEFAULT  ON  HEIGHT  *  GEOPOTENTIAL(ATMOSPHERE) ,  GEOMETRICCAIRCRAFT) 

C  INTERNAL  PROGRAM  UNITS  HEIGHT  GEOPOTENTIAL  METERS(ATMOSPHERE) , 

C  GEOMETRIC  METERS  ALL  OTHER  HEIGHTS  ANO  LENGTHS,  TEMPERATURE 
C  DEGREES  KELVIN,  PRESSURE  KILOPASCALS  (KPA),  SPEED  METERS  PER  SECOND. 

COMMON  /ATMCON/  REARTH , GO ,RSTAR,R0M0 , R0G0M0 

C  REARTH=RADIUS  OF  EARTH  FOR  CONVERSION  GEOMETRIC  TO  GEOPOTENTIAL 
C  METERS.  ROMO»RSTAR/MO  ANO  ROGOMO=RSTAR/(GO*MO) 

C  WHERE  RSTARsUNIVERSAL  GAS  CONSTANT=8.31432E3  JOULES  /  (KMOL-DEGK) , 

C  G0*9.8O665M/SEC"2,  ANO  M0*MEAN  MOLECULAR  WEIGHT  OF  STANDARD  DRY 
C  AIR  (28.9644  KG/KMOL)  (SEE  U.S.  STANOARD  ATMOSPHERE  1976) 

CHARACTER'8  NOWINO , FINISH 
CHARACTER'8  TPUNIT(3) 

CHARACTER'8  BUF(4), BLANK 
REAL  DUMMY{3) ,DEFARY(3) 

LOGICAL  GEOMET, NOCAP .TRUE, FALSE 

DATA  N OWIND/'NOWI HD S1 /.FINISH/' ENO1/ 

DATA  TPUN IT/1 HEIGHT  1 , '0 1 RECT ' , 1  SPEED 1 / 

OATA  8LANK/'  '/ 

DATA  0EFARY/3'0./ 

OATA  TRUE/. TRUE. /.FALSE/. FALSE./ 


GPHW(1 )*-5E3 
D1RCD-0. 
SPEED ( 1 )*0. 


C 

C  READ  TITLE/NOWINOS  CARD  ANO  INTERPRET 
C 

C  READ (5,5, EN0*200 )  BUF 

5  FORMAT £9A8) 

C 

C-  BRANCH  AAROUND  FOR  NO  UINOS 
C 

GOTO  200 

C  CALL  LJUST(8,3,KARD,8UF) 

CALL  LOKUP<8, 1 .NOWIND , BUF( 1 ) , ISTND ,*6, *7) 

6  IF(BUF(1 ) .EO. BLANK)  GO  TO  7 
GO  TO  200 

7  URITE(7,8)  TITLE 
URITE(7,9)  8UF 

8  FORMAT (M',30A4) 

9  FORMAT ( 1 0 1 , 5X , 9A8) 

C 

C  READ  UNITS  CARD  AND  INTERPRET 
C 

C  REAO(5,5,ENO=200)  BUF 

C  CALL  L JUST (8, 3, KARO, BUF) 

CALL  UNITIS<BUF<1),HTA8L,6,IHUNI7,TPUNIT(1),5) 

CALL  UNIT1S(BUF(3), STABL ,9, I SUNI T ,TPUNIT(3) ,3) 

GEOMET  » . NOT . ATMPOT ( I  HUN  I T ) 

C 

C  READ  IN  DATA  VALUES  H-OIR-SPD.  CONVERT  TO  INTERNAL  UNITS, 
t  COMPUTE  TURN  (RATE  OF  DIRECTION  CHANGE  PER  METER) 

C 

OLDTRN»0. 

NOCAPxFALSE 
DO  40  N*2,80 

C  READ (5 , 555 , EN0*45 )  DUMMY 

555  FORMAT(3F8.0) 

C  CALL  L  JUST ( 8 , 3 , KARD , BUF ) 

IF(BUF(1).EQ. FINISH)  GO  TO  45 

C  CALL  FFA2NCKAR0, 1,8, 3, DUMMY, DEFARY, KERR) 

GPHU(N )=0UMMY( 1 )*CHTA8L ( I  HUN  I T ) 

D I R(N )=0UMMY(2) 

SPEED(N)=0UMMY(3)*CSTABL(ISUNIT) 

I F < GEOMET )  GPHW( N )=GPHU(N )/( 1 ,+GPHWC N ) /REARTH ) 

I F(SPEED(N) .EO.O. )  GO  TO  35 


1 


a 


OLDTRN*(AMCO(AMCO(DIR(N)-DIR(N- 1),360. )+540. ,360. )•  180. )/ 

♦  (OPHW(M) •GPHW<M* 1 ) ) 

TURN(N- 1  )«OU)TRR 

GO  TO  40 

35  TURN(N-1)«OLDTRN 
OLDTRN«0. 

40  CONTINUE 
N«81 

NOCAP«TRUE 

WR1TE(7,41) 

41  FORMAT < 1  H-DIR-SPO  READING  TERMINATED  AFTER  79  ITEMS.1 ) 

45  NWINDS*N- 1 

lF(NUlNOS.EQ.SO)  GO  TO  50 

NW!NOS»NW!NDS+1 

GPHU(NUIN0S)*130274. 

SPEED ( NWI NOS )*0. 

DIR{NWIN0S)«0. 

TURN (NWI NOS • 1 )*OIOTRN 
C 

C  WORK  DOWN  TURN  AND  OIR  FOR  THE  CASE  SPEED=0. 

C 

SO  DO  60  NN>2,NUIN0S 
N-NWINOS-NN+2 

I F( SPEED (N) . EQ.O. )  GO  TO  60 
t  F(SPEED(N- 1 ) .EQ.O. }  GO  TO  55 
OLDTRN-TURN(N-I) 

GO  TO  60 

55  TURN(N- 1 )*OLDTRN 

DIR(N-1)=0IR(N>-01DTRN*(GPHW(N>-GPHW(N-1)> 

OLDTRN-O. 

60  CONTINUE 
C 

C  PRINT  OUT  IN  ORIGINAL  UNITS 
C 

URITE(7,90)  HTA8L<IHUNIT),STABUISUNIT) 

90  FORMAT! ,0',T4,‘HEIGHT'iT16,,DIR',T23, 1  SPEED' /5X,A9,T16, ’DEG',T25, 

♦  A9) 

NPRNT*NWINDS- 1 
I F(NOCAP)  NPRNTaNPRNT+1 
DO  100  N*2,NPRNT 
HPRNT*GPHW(N) 

I F ( GEOMET )  HPRNT*HPRNT/( 1 . • HPRNT/REARTH) 

HPRNT*HPRNT/CHTA8L < I  HUN  I T ) 

SPRNT*SPEEO(N)/CSTABL{ ISUNIT) 

WRITE  (6,95)  HPRNT,DIR(N),SPRNT 
95  FORMAT ( 1X,3F9.0) 

100  CONTINUE 
RETURN 


C 


C  MOUtHOS  SELECTED 
C 

200  NWINOS-2 

GPHW( 2 )« 130274. 

SPEED <2)=0. 

DIR(2)*0. 

TURN(1)«0. 

C  URITE  (6,210) 

210  FORMAT ( 'ONOWINOS  SELECTED.1) 


RETURN 

ENO 


c 

2  •*•***•**»*•»«»»•»*•«»**•*•»»«»*»•*•*»»•«••»•*»•*»**»»*»**»»«•»»»»•* 
C  *  RAY  TRACE  ROUTINES  ■  T1MPHI .ACMOVE, FILIMS.RAYORG.RAYTRK, RATES  * 

C  •  AO VANS , AS TUBE , RCRVI T , RECORD , RCSPCL  * 

Q  ******«•******'******«**«*****«#***«**•***'*******»*****«**•«*•******** 

c 

C  THE  RAY  TRACING  ROUTINES  ARE  RESPONSIBLE  FOR  EMITTING  AND  TRACKING  RA 
C  FROM  AIRCRAFT  TO  GROUND,  UNDER  CONTROL  OF  THE  MAIN  PROGRAM  SONBOM. 

C 


C 

Cxsssu»3HHnisi»«tnan«ii3as3nausxsssi»sazzcs33Ssss3»iiiui»a 


c 

SUBROUTINE  ACMOVE ( T , NCOE , NOOE  C } 

C 

C  ACMOVE  INTERPOLATES  AIRCRAFT  TRACK  SPLINE  TO  CURRENT  VALUE  OF  EMISSIO 
C  TIME.  COMPUTES  AND  STORES  IN  COMMON  BLOCK  THE  POSITION  AND  VELOCITY 
C  OF  THE  AIRCRAFT,  THE  LOCAL  SOUND  SPEED  AND  UINO,  THE  AIRSPEED  AND  ITS 
C  RATE  OF  CHANGE,  THE  MACH  NUMBER  ANO  ITS  RATE  OF  CHANGE,  THE  CLIMB  AND 
C  BANK  ANGLE  ANO  THE  WING  LOADING,  THE  DIRECTION  COSINES  OF  A  “RAY  CONE 
C  COORDINATE  SYSTEM"  ANO  THEIR  RATES  OF  CHANGE.  PRINTS  OUT  THE  INFORMAT 
C  ON  THE  AIRCRAFT  POSITION  ANO  MOTION,  BOTH  IN  AN  AIRBORNE  REFERENCE  FR 
C  ANO  A  GROUND  REFERENCE  FRAME. 

C 

INTEGER  SKEU(A) 

DIMENSION  RAC(1156,3),  VXYZ<1156,3) 

DIMENSION  RO<3),RDOT<3),ROOOT<3),RODDOT(3),RLWDOT(3),OMEGA<3> 


COMMON  /ACSPOT/  TIME ,XRQ, YRO.ZRO.XOOT , YDOT , ZDOT , AIRSPD , ASPDOT , 

+  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU,EK(3,3),EKD0T<3,3),GL0AD,HEADIN,CLIMB,BANK, 

♦  XOOOT , YDOOT , ZDDOT , XDDDOT , YDDOOT , ZDDOOT 
EOU I  VALENCE  ( R0< 1 ) , XRO ) , <  XOOT , ROOT  < 1 ) ) , <  ROOOT ( 1 ) , XOOOT ) , 

♦  ( ROOOOT ( 1 ) , XDDOOT ) 

COMMON  /ATMCON/  REARTH , GO , RST AR , ROMO , R0G0M0 

COMMON  /FLIGHT/  NFIXES, TIMEAC0 156)  ,XAC<  1 156) ,  YAC(  1 156)  ,ZACC  1 156) . 
+  VX(1156) , VY< 1156) ,VZ(1 156) , FMACH(1 156) , CA(1 156) 

EQUIVALENCE  (RACI1 , 1 ) ,XACC1) ) 

EQUIVALENCE  (VXYZ<1,1),  VX(1)) 

COMMON  /ATMSPH/  GAM, C,U, V,DCDZ,DUDZ, DVDZ,D2CDZ2,02UDZ2,D2VDZ2, RHO 
REAL  GAM ,  C ,  U ,  V 


COMMON  /PRINTS/  T I TLEI30) , T IMLBL 
CHARACTER"!.  TITLE 
CHARACTER'S  T IMLBL 


COMMON  /PR1NTC/  KTPSIG.CVRTIM 
LOGICAL  CVRT1M 


REAL  TIMCVR 

COMMON  /SPLINE/NSP,SS(100,3),AS(100f3),BS(100/3),CS(100,3), 
+  DS(100,3) 

REAL  SS,AS,BS,CS,OS 

INTEGER  NSP 

COMMON  /STSPLN/  ISTT 
INTEGER  ISTT 

OATA  DGPRAD/57. 295780/ 

DATA  SKEW/2,3,1,2/ 


TIME*T 

C 

C-  RETURN  IF  THE  TIME  IS  BEYOND  THE  START  OF  THE  SPLINE 
C 

334  IF  (NOOE.LE.O)  RETURN 


DT  ■  TIME  -  TIMEAC(NOOEC) 

DT2  ■  DT*OT 
DT3  *  DT2-0T 
0T4  *  0T3*0T 

DO  10  K=1,3 

ROOO  a  AS(N00E,O/12.*DT4  ♦  BSLNOOE , 0/6.  *  DT3 

1  ♦  CS(NOOE, 0/2.0  *  0T2  ♦  VXYZ(N00EC,O*DT 

2  ♦  RAC(N00EC,O 

ROOT (K)  *  AS(N00E,O/3.  *  DT3  ♦  BSCNOOE.O/2.  *DT2 
1  ♦  CSCNOOE.O  *  OT  +  VXYZCNOOEC.K) 

RDOOT (O  *  AS(N00E,O  *  0T2  ♦  BS(N00E,O  •  DT 
1  ♦  CSCNOOE , K) 

RDDDOTOO  *  2.0  *  AS(N00E,O  *DT  ♦  BS(N00E,O 
10  CONTINUE 

CALL  FNDLYR(ZR0,*250) 

CALL  AIR((ZRO)) 

CO*C 

uo*u 

VO*V 

COOT=OCDZ*ZDOT 

UAS*XDOT-U 

VAS=YOOT -  V 

ASPH=UAS**2+VAS**2 

AIRSPO=SQRT(ASPH+ZDOT**2) 

A$PH=SORT (ASPH) 

RLWOOT ( 1 )=ROOOT ( 1 ) -OUOZ*ZDOT 
RLWDOT ( 2 )=ROOOT( 2 ) -DVOZ'ZDOT 


RLVJDOT ( 3  ) *RDDOT ( 3 ) 

ASPOOT*  < RLWDOT ( 1 )*UAS*RLUDOT ( 2  >*VAS+ZDOT*RLWDOT ( 3  > ) / A I RSPD 
XMACH-A1RSPO/CO 

XMADOT  ■< ASPOOT*CO • A I RSPO*CDOT ) /C0*«2 

IF  (XMACH.GT. 1 . )  GO  TO  15 

XM(J*90. 

XMUDOT  =0 . 

SINMU*1. 

COSMU*0. 

GO  TO  20 

15  SINMU*1 ./XHACH 

C0SMU*S0RT(1.-SINHU*»2) 

XMJsOGPRAO*  AS  I N  (  S 1 NMJ  ) 

XMUDOT  ■  •  DGPRAD*XMADOT*S  I  NMU**2/C0SMU 
20  EK(1,1)*UAS/AIRSP0 
£KC2,1)*VAS/AIRSP0 
EK(3, 1 )*ZDOT/AIRSPO 
EK  ( 1 , 2 )*VAS/ASPH 
EKC  2 , 2 )= - UAS/ASPH 
EK(3,2)S0. 

DO  30  K*1 ,3 
K1*SKEW(K) 

K2*SKEU(K*1 ) 

EK(K,3)*EK(K1 ,2)*EK{K2, 1  )-£K(K2,2)*EIC(Kl , 1 ) 
OMEGA<K)*<RLWDOT(K1}«EK<K2,1)-RLUDOT(K2>*EKCIC1,1))/AIRSPO 
30  CONTINUE 

FACT«(OMEGA< 1 )*EK( 1 , 1 )*OMEGA<2)«EK<2, 1 ) )/(EX(1 , 1 )**2+EK(2, 1 >»»2) 
HL0A0»0. 

VLOAD*G0*EK  C  3 , 3 ) / ( 1 . *ZRO/REARTH )**2 
DO  40  K-1,3 

OMEGA(K)*OMEGA<K) - FACT*EK<K, 1 ) 

HLOAD*HLOAO+RDDOT<K)*EK(K,2) 

VLQAD»VLQAD*RDD0T(K)*EK<K,3> 

40  CONTINUE 

GLOAD*SQRT<HLOAO**2+VIOAO**2)/GO 
BANK=0GPRAD*ATAN2( HLOAD , VLOAD ) 

HEAD  IN«0GPRA0*ATAN2<  -EKC  1,1) ,  -EICC2, 1 ) )+180. 

CLIMB«0GPRA0*ASIN(EK(3, 1 ) ) 

DO  50  K*1 ,3 
K1*SKEW(K) 

K2*SKEW(K+1 ) 

0M1 *OMEGAOC1 ) 

0M2*0MEGA(K2) 

DO  50  1*1,3 

EKDOT<K,l)*EK(K1,l)*OM2-EKCK2,l>*ON1 
50  CONTINUE 

C  WRITE(7,60)  TITLE 
60  FORMATC 1 1 ' ,30A4) 

TPRINT=T1MCVR((TIME),2) 

UR  I  TEC  7, 65)  TIMlSL,TPRINT,XRO,rRO,ZRO,XMACH,GLOAD,SANK 
65  FORMAT ( ' OAI RCRAFT  MANEUVER  OATA'/'O1 ,T4, 'TIME' ,T16, 'X' ,T26, ' Y ’ ,T36 
♦, ' Z 1 ,T45, 'MACH' ,T54, ‘LOAO’ ,T64, 'SANK' /T4, AS, T15, 'MET1, T25, 'MET' 

+  , T35 , 'MET  1 ,T46, 'NO. 1 , T55, • G ' *S • , T64 , 'DEGS. V1X,4F10.0, 2F10.5 , F10. 1 


C 

c 


HEADG*OGPRAD*AT  AN2( • XDOT , -YD0T>180. 
GNTSPD»SORT(XDOT**2+YDOT**2+ZDOT**2) 

GCLM8«0GPRAD*ASIN<ZD0T/CNTSP0) 

C  UR I TE ( 7, 70  )  AI RSPO , UAS , VAS , ZDOT , CL I MB , HE AO  I N , GNT  SPO , XDOT , YDOT ,  ZDOT , 

C  +GCLMB , HEAOG 

C  70  FORMAT  ( 'O', Til, IOC*1 ) ,T25,  'SPEED  MPS'  ,T41 , 10<  '  - '  ) ,  IX, 5(  1  - '  )  ,2X, '  A 
C  ♦NGLE1 ,3X,5( ' - 1 )/T14, 'TOTAL' , T23, 'X-COMP1 ,T33, 1 Y-CQMP* ,  T43, 'Z-COMP1 
C  *,754, 'CLIMB', T64, 'HEADING'/'  AIR' ,T11 ,4F10.0,F10.2, F10. 1/ '  GROUND' 
C  ♦,T11,4F10.0,F10.2,F10.1) 

RETURN 

200  URITE(6,210)  T,TIMEAC(1),TIMEAC(NFIX£S) 

210  FORMAT  { '  IN  CALL  TO  ACMOVE,  TIME*  "  ,F10.1 , 1 1 1  IS  OUTSIDE  RANGE'", 
♦F10.1,"'  TO"',F10.1) 

RETURN 

250  URIT£(6',260)  T,ZR0 

260  FORMAT ( 1  IN  CALL  TO  ACMOVE  AT  TIME1 1 1 ,F10.1 ,  "  •  AIRCRAFT  IS  AT  ALT 
+ITUOE  Z*1  1 1 , F10.2, 1 1 1  METERS  AND  OUTSIDE  ATMOSPHERE  TABLE.1) 

STOP  600 
END 


C  3X23X3: 

03X3333: 

C 


SUBROUTINE  FILIMS(*) 

C 

C  FILINS,  GIVEN  THE  INFORNATION  FRCH  THE  ACMOVE  SUBROUTINE,  ANO  THE  WIN 
C  VELOCITY  ANO  SOUND  SPEED  AT  THE  GROUND,  COMPUTES  THE  LIMITS  OF  PHI  AN 
C  AT  THE  ADMITTANCE  ELLIPSE  FOR  THE  GROUND  LEVEL.  PRINTS  OUT  THE  LIMITt 
C  PHI  ANGLES  FOR  THE  ARCS  INSIDE  THE  ADMITTANCE  ELLIPSE,  IF  ANY. 

C  ALTERNATE  RETURN  TAKEN  IF  RAYS  DO  NOT  TOUTCH  THE  GROUNO  OR  AIRCRAFT  I 
C  SUBSONIC. 

C 

DIMENSION  ZRO(5),TRNO(5) 


COMMON  /ACSPOT/  TIME , XRO , YRO , ZRO , XDOT , YDOT , ZDOT , A I RSPO , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUOOT , COSMU , 

♦  SINMU,EK(3,3),£KDOT(3,3),GLOAD,H£AOtH,CLIMB,BANK, 

+  XDOOT , YDDOT , ZDOOT , XDODOT , YDODOT , ZDDOOT 

EQUIVALENCE  (SINGAM, EK(3 , 1 ) ) , (COSGAM, EK(3 ,3) ) 

COMMON  /GROUNO/  GLAYER , ZGRNO , CGRNO , UGRNO , VGRND , REFL FC 
INTEGER  GLAYER 

COMMON  /RAYL1M/  NLIMS, BEG<2) , EHO<2) 

DATA  OGPRAD/57. 295780/, TUOPI/6. 28318531/ 

IF  (XMACH. LT.1.)  GO  TO  102 
UOMG*UO- UGRNO 
VOMG-VO- VGRND 

ALPHA1*1 .*$INMU*(UOMG*EK(  1 , 1  )*V0MG*EK(2, 1 )  )/C0 
ALPHA2*COSMU* ( U0MG*E  K ( 1 , 2 )♦ VOMG’EK  <  2 , 2 ) > /CO 
ALPHA3*C0SMU*(U0MG*EK( 1 , 3 >♦ V0MG*EK( 2 , 3 ) )/C0 
A0*ALPHA1**2* . 5* ( ALPHA2**2*ALPHA3**2  > 

A 1  *  -  2 . 'ALPHA 1 *ALPHA3 
A2* ■ 2 . *ALPHA1 *ALPHA2 
A3* . 5*( ALPHA3**2 • ALPHA2**2 ) 

A4«ALPHA2*ALPHA3 
S I NMU2*S I NMU**2 
COSMU2*COSMU**2 
CGFACT*(CGRNO/C0)**2 
CSGM2*COSGAM**2 

AO*AO - CGFACT*( S I NMU2*CSGM2* ( 1 . • . 5  *CSGM2 ) *COSMU2 ) 

A 1 *A1 - CGF ACT*2 . *S I NGAM*COSGAM»S I NMU’COSMU 
A3=A3*CG  FACT* . 5  *<  CSGM2 ) *COSMU2 
A34=SCRT(A3**2+A4**2) 

OFULI M=SQR  T ( A 1 **2*A2**2 )+A34 
CPPMX»DFULIM+3.*A34 
EPS*5E'6*0FULIM 
PHI*-90./OGPRAD 


F0=A0-A2-A3 

PH10-PH1 

PHIBEG-PHI 

KZR0»1 

IF  (DFULIM.LT.ABS(AO) .OR .DFUL1M.EQ .0. )  GO  TO  100 
5  IF  (PHI0.GT.PHI8EG+TW0P! )  GC  TO  100 
SINPHI*SIN<PHI) 

COSPHI*COS<PHl) 

TWOPH I *PH I +PH I 
COS2FI»COS(TWOPHI ) 

SIN2FI*SIM<TUOPHn 

F«A0+A1 *COSPH I +A2*S I NPH I+A3*COS2F I +A4*SI N2F I 
IF  (ABS(F).LT.EPS)  GO  TO  25 
IF  <F*FO.L£.0.)  GO  TO  10 
C  CASE  NO  ZERO  CROSSING.  ADVANCE  PHI 

FPR« - A 1 *S I NPH I +A2*COSPH I • 2 . * <  A3*S I N2 F I  - A4*COS2 F I ) 
FPPMX*S 1 GN ( CPPMX , F ) 

0PH 1 1 *FPR/ FPPMX 

DPHI2*S0RT(FPR*«2*2.*F*FPPMX5/CPPMX 
DPHI*AMAX1(A8S(DPHI 1 ),0PH12*0PHI 1 , 1 . E - 5  > 

PHIO*PHI 

FO»F 

PHI*PMI+OPHI 
GO  TO  5 

C  CASE  ZERO  IS  CROSSED.  LOCATE  ZERO  BY  HALVES. 

10  PHIHI=PHI 
FHI*F 

15  PH I » . 5* ( PH I H I +PH I Q) 

SINPHI*SIN(PH1 ) 

COSPHI»COS(PHI) 

TUOPHI=PHI*PHI 
COS2FI*COS(TWOPHI ) 

SIN2FI=SIN(TWOPHI) 

F=>AO+A1*COSPHI  +A2*S  I  NPH  I  +A3*COS2F  I  +A4*S  1N2FI 

IF  (ABS(F).LT.EPS)  GO  TO  25 

IF  (F'FHI.GT.O.)  GO  TO  20 

PHIO*PHI 

FO=F 

GO  TO  15 
20  PHIHI*PHI 
FHt  *F 
GO  TO  15 

25  FPR*-A1*SINPHI*A2*COSPHI-2.*(A3*SIN2FI-A4*COS2FI) 
OPH I *ABS(FPR/CPPNX) 

OF».5*ABS(FPR)*OPHI 
IF  (0F.LT.EPS)  GO  TO  30 
MULTsI 

SGN=SIGN(1.,FPR) 

GO  TO  50 

30  FPPRs ■ A1*COSPH I • A2*S I NPH I -4 . *(A3*C0S2F I +A4*SI N2F I ) 
0PHI=ASS(2. *FPPR  5/CCPPMX+4 . *A34 ) 
DF=ABS(FPPR)*OPHI*OPHI/6. 

IF  (0F.LT.EPS)  GO  TO  35 
HULT=2 


SGN—SIGN(1.,FPPR) 

GO  TO  SO 

35  FP3R«A1*S1NPHI -A2*COSPHl*8.*<A3*SIN2Fl • A4*COS2FI ) 

DPH I *ABS(3 . *  FP3R ) / < CPPMX+ 1 2 . * A34  > 
DF«ABS<FP3R)*DPHI«OPHI*OPH!/24. 

IF  (DF.LT.EPS)  GO  TO  40 
MULT*3 

SGN*SIGN<1.,FP3R> 

GO  TO  50 

40  FP4R*A 1 *COSPH I *A2*$ INPHI+16. « ( A3*COS2F I +A4*S I N2F I ) 

MULT«4 

SGN» - S  t  GN< 1 . , FP4R ) 

DPHI»TWOPI 
50  DO  55  K*1,MULT 
ZRO(KZRO)*PHI 
TRND(KZRO)*SGN 
SGMat  •  SGN 
KZR0«<ZRO1 

IF  (K2RO.GT.5)  GO  TO  100 
55  CONTINUE 

PHIO*PH1+OPH! 

PHI*PHIO 

TVIOPHI»PHI+PHI 

FO*AO+A1*COS<PHI )+A2*SIN(PHI )+A3*COS(TyOPHI )*A4*SIN(TU0PHI ) 

GO  TO  5 

100  IF  (KZRO.GT. 1 )  GO  TO  110 
IF  (FO.GE.O)  GO  TO  105 
102  NLIMS»0 
GO  TO  130 
105  NLIHSxl 

BEG(1)x-90. 

END<1)»270. 

GO  TO  130 
110  KZROxKZRO-1 

IF  (MGO(KZRO,2).EQ. 1 )  GO  TO  115 
KZRO*KZRO*1 

ZRO(KZRO)*ZRO(1 I+TWOPI 
TRND (KZR0)=TRND( 1 ) 

115  NLIMS*(KZRO- 1 )/2 
L*1 

IF  (TRNO(I).LT.O.)  L*2 
00  120  N«1 ,NLIMS 

BEGIN  WRO(N*2H-2)»OGPRAO 
EN0(N)*ZR0<N*2*L-1)*DGPRAD 
120  CONTINUE 

130  IF  CNIIMS.GT.O)  GO  TO  150 
C  WRITEI7, 145) 

145  FORMAT ( '0  RAYS  WILL  NOT  TOUCH  GROUND  OR  AIRCRAFT  IS  SUBSONIC.1) 

RETURN  1 
150  CONTINUE 

C  150  WRITEC7, 155)  MUMS 

155  FORMAT <*0* ,T10, 12, '  PHI -ANGLE  INTERVALS:') 

DO  165  N=1 , NL IMS 

BEG 1 =AMOO ( AMOO ( BEG( N ) , 360 . )+450 . , 360 . ) -  90 . 


EW01*AMOO(AMOO(ENO(N),340.)*450.,340.)-90. 

C  WR1TE(7, 140)  N.BEG1 , EN01 

160  FORMAT  ( ‘OINTERVAL 1 , 12, 1  FRCM>,f7.2,'  DEGREES  T0\F7.2, 

♦  1  DEGREES.1) 

145  CONTINUE 
RETURN 
END 


c 

CMassisiMaEsss5si*s»K*i*sasa3*ssss«*ss33s2SS3sssiaaissaiaM*iaisa* 
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c 

SUBROUTINE  RAYORGC*) 


C 

C  RAYORG,  FOR  EACH  EMISSION  TIME  ANO  FOR  EACH  VALUE  OF  PHI  LYING  WITHIN 
C  THE  ADMITTANCE  ELLIPSE,  COMPUTES  THE  INITIAL  VALUES  OF  POSITION,  RAY 
C  NORMALS,  “FREQUENCIES",  ANO  THEIR  RATES  OF  CHANGE.  SETS  CURRENT  TIME 
C  EQUAL  TO  EMM I SS I ON  TIME.  THE  RATES  OF  CHANGE  ARE  WITH  RESPECT  TO  NOT 
C  ONLY  CURRENT  TIME,  BUT  ALSO  THE  RAY  PARAMETERS  OF  PHI  ANGLE  ANO  OF 
C  EMISSION  TIME.  IF  RAY  TRACE  PRINTING  IS  SELECTED,  PRINTS  OUT  THE  INIT 
C  RAY  TRACE  VALUES. 

C 

C 

COMMON  /ACIONT/  I0ENT 
CHARACTER*8  IOENT 


COMMON  /ACWE1G/  ACWT.ACL 

COMMON  /RAYVAR/  ZDIR , PICK, RTPAAO.ATTEN , SIGMA ,X,Y, Z, CAGE, XF, YF ,ZF , 

♦  XT , YT , ZT , XS , Y  S , ZS , XSS , YSS , ZSS , XSSS , YSSS , ZSSS , P3 , 

♦  P3F,P3T,P3S,XFS,YFS,XTS,YTS,ZFTP3,XFTZ,YFTZ,ZFTZ, 

♦  ZFA , ZTA , P3FTZ , P3FA , P3TA , AREA , DAGOS 
REAL  SIGMA, X, Y,Z,DAG£ , XF , YF ,ZF , XT, YT.ZT 

REAL  XK(3),XKF<3),XKT<3) 

REAL  RENORM 

REAL  XKS<3),XKFS(2),XKTS(2),XKFTZ(3),XKSS(3),XKSSS(3> 

EQUIVALENCE  <XK( 1 ) ,X) , <XKF( 1 ) ,XF > , (XKT< 1 ) ,XT> , (XKSC 1 > , XS) 
EQUIVALENCE  CXKFSC 1 )  ,XFS) ,  (XKTSO  ),XTS) ,  (XICFTZC 1 > ,XFTZ) 
EQUIVALENCE  <XKSS< 1 )  ,XSS) , (XKSSS( 1 ) ,XSSS) 

COMMON  /RAYNIT/  KGMH , NDCRVS , NUCRVS , IUPOWN , TO.PHI 0, XO, YO, ZO, 

♦  P10,P20,P30,OMEGA,DELTA0,P1F0,P2F0,P3F0, 

♦  OMEGAF ,XT0 , YTO, ZT0.P1T0 , P2T0, P3T0, OMEGAT ,XSO , 

♦  YSO , ZSO , P3S0 , RHOO , PCONST , NAGES , AGES! 20 ) 

INTEGER  KGMH, NDCRVS, NUCRVS, IUPOWN 

REAL  XK0(3) ,PK0<3) ,PKF0<3) ,XKT0<3) ,PKT0(3) ,XKS0(3) 

EQUIVALENCE  (XK0<1 ) ,X0) , <PK0< 1),P10) , (PKF0(1 ) ,P1 F0> , CXKTOO ) ,XT0) 
EQUIVALENCE  CPKTOO  )  ,P1T0)  ,  CXKS0<1 )  ,XS0) 

COMMON  /ATHCON/  REARTH , 50 ,RSTAR ,ROMO, R0G0M0 

COMMON  /ACSPOT /  TIME, XRO , YRO , ZRO , XDOT , YD01 , ZDOT , A I RSPO , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU,EK(3,3),EKDOT(3,3),GlOAD, HEAD  IN, CLIMB, BANK, 

♦  XDOOT , YDDOT , ZDDOT , XDDDOT , YDDDOT , ZDDDOT 
REAL  XKRO(3),XKDOT(3) 

EQU I  VALENCE  (XKROC 1 ) , XRO ) , <  XKDOT ( 1 ) , XDOT ) 


COMMON  /ATMSPH/  GAM , C ,U, V.DCDZ ,DUDZ , DVOZ,D2CDZ2 ,D2UDZ2 , D2VDZ2 , RHO 
REAL  GAM , C , U , V 


COMMON  /CLASES/  CNAMES<30) 

CHARACTER'S  CNAMES 

COMMON  /CLASSS/  NRCURV(2, 2), TYPRAY{3,2,2) ,D IRECT , LOFT ,UP,DOUN 
LOGICAL  TYPRAY , D I RECT , LOFT , UP , DOWN 

COMMON  /PRINTS/  T1TLEC30) ,T IMLBL 
CHARACTER'^  TITLE 
CHARACTER'8  T IMLBL 

COMMON  /PR1NTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM 
REAL  TIMCVR 

COMMON  /RYCTRL/  NORAYS , STNO ,UL , UR, LL.LR . PRTRAY , T1MBEG.DELTIM, 

♦  NT1MS.PHIBEG, DELPHI, NPHIS 
LOGICAL  NORAYS, STNO, ULfUR,LL,LR, PRTRAY 

COMMON  /RPOSN/  NPTR, CPOSN , RT (200) ,RXYZC 200,3) , RAGEC 200) , 

♦  RPf ACT ( 200 ) , RVL I  f  T , REMEM 
REAL  RT ,RXYZ, RAGE , RPFACT 

INTEGER  NPTR.CPOSN 
LOGICAL  REMEM 

DATA  DGPRAD/57. 295780/ 

NPTR  a  0 
NAGESal 
D AGE =0.0 
MEDHlal 

COSPH I aCOS (PHIO/DGPRAD) 

SINPH laSI N(PH IO/OGPRAD ) 

RENORM=0.0 

DO  10  X=1 ,3 

XKO(K)=XKRQ(K) 

EHa.SINPHI'EK(X,2)-COSPH[*EK(K,3) 

EHOOTa- SINPH I'EXDOT (K,2) • COSPHI 'EKDOT (IC,3) 

PKQ(K)=EK(K, 1 )*COSMU*EH/S!NMU 

PKFO(K)=(COSMU*(  •COSPHI*EK(K,2)*SINPHI*EK(K,3) ) )/SINMU 
PKTO(K)=EKDOT(K, 1  )*(EHOOT'COSMLI‘  EH'XMUDOT  /  (DGPRAD'SI  NMU)  )/SINMU 
RENORMaRENORM+(PXO<K)  )"2 
10  CONTINUE 

RENORM=S I NMU'SQRT ( RENORM ) 

CALL  FNOLYR(ZO, *20) 

20  CALL  A I R < { 20 ) ) 

RHO0=RHO 


PCONST=AIRSPD*’2*SORT( .5*RHO0) 
PCONST =AI RSPO*SQRT(0 . 5'RHOO) 
DELTAOaAIRSPO 
CSOD=CO*SINMU 


OO  25  K»1,3 

PKOOO»PKOU)/RENORM 
XKSO  (  K)  =CSQO*PKO  OO 
XKTOOOsXKDOTOO-XKSOOO 
25  CONTINUE 
XSO=XSO+UO 
YS0=YS0+V0 
XT0*XT0-U0 
YT0*YT0-V0 

RTPAAO*SQRT ( P 1 0**2+P20**2 ) 

0ELTA0*C*SQRT (P30**2+RTPAAQ**2 ) 

OME  GAsC  E  L  T  AO+U*P 1 0+ V*P20 

OMEGAT*ASPOOT+(DUOZ*P10*OVDZ*P20)*ZDOTHI*P1TO+V*P2TO 

0M£GAFsU»P1 F0*V*P2F0 

P3S0* •OCOZ*D£LTAO/CO - PI 0*DUDZ - P20*DVDZ 

P3T0*P3T0-P3S0 

IUP0WN*1 

IF  (P30.LT.0.)  IUPOWN-2 
IF  ( IUPDWN .EQ. 1 . AMO . .NOT .UP) RETURN  1 
IF  ( 1UPDUN .EQ.2.AN0 . .NOT .DOWN )  RETURN  1 
SIGMAsTO 

ZDIR=SIGN(1 . ,P30) 

DO  50  K=1,3 
XKOO*XKO(IO 
XKF(K)aO.O 
XKT  (X)»XKT0(K) 

50  CONTINUE 
P3F*P3F0 
P3T=P3T0 

CALL  RATES(*100, *100) 

AREA«0. 

ATTEN»1 . 

RVL I FT=<ACUT*GLOA0*GO*COSMU*COS( (PHI  0- BANK J/DGPRAO )/ 

♦  (RHOO*SINMU*AIRSPD**2)) 

IF  ( .NOT .PRTRAY)  RETURN 
C  URITE(7,60)  TITLE 

C  60  FORMAT ( 1 1 ' ,30A4) 

C  TPR INT =TIMCVR( (TO) ,2) 

C  FIPRNT=AMC0(AMO0(PH10,360. )+450. ,360. )-90. 

C  AZIM»PHAZIM<Q.) 

C  URITE(7,65)  TPR I  NT , TIMLBL , F1PRNT ,P10, P20 , AZIM 

C  65  FORMAT <' O’, T20, 'DATA  FOR  RAY  DEPARTING  AIRCRAFT  TIME*' , F10.0, 1X,A8 
C  +,'PHI  ANGLES' ,F7. 2,'  DEGREES. ' /T15 ,' PI =', G14.5 , 1 , P2= ', G14 .5 ,' PHASE 
C  +  NORMAL  AZIMUTH*', F6. 0, '  DEGREES.') 

C  TPRINT=TIMCVR(SIGMA,2) 

C  EL£V=PHELEV(0. ) 

C  UR  I TE( 7, 70)  TIMLBL, TPR I  NT ,X , Y , Z,P3, ELEV, C , ZS , AREA, DAGE 
C  70  FORMAT( 'O’ ,T5, 'SIGMA' ,T18, ' X • , T28, ' Y ' , T39, 1 Z ' , T45 , ' P3 ', T53 ,' PHASE ' 
C  ♦,765, ’C’,r73, '0Z/0S',T81, 'AREA', 791, ' AGE ’ /T5 , AS, 71 7, 'MET',T27, 

C  +'MET' ,738, 'MET' ,754, 'ELEV' , 763, 'M/SEC' ,T73, 'M/SEC' ,T79, 'M**2/SEC' , 


C  +T89, 'MET**.5'/ 

C  +1X,F10.1,3F10.0,G10.3,F6.1,2F10.1,2G10.4) 

RETURN 

100  WRITE(6, 101 ) 

101  FORMAT ( 1  IMPROPER  RETURN  FROM  RATES  IN  RATORG') 
RETURN 

ENO 


c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


SUBROUT  J  ME  RAYTRKC  GFLAG , RCBLG ,  CFUG ,  *  ) 

RAYTRK,  FROM  THE  INITIAL  VALUES  SUPPLIED  FROM  RAYORG,  TRACES  THE  RAY 
TO  THE  GROUND  LEVEL  ANO  REFLECTS  AS  MANY  TIMES  AS  NECESSARY.  CONTROLS 
THE  COMPUTATION  OF  THE  CHANGE  IN  NOT  ONLY  THE  POSITION  OF  THE  RAY,  BU 
ASSOCIATED  TERMS  SUCH  AS  THE  RAY  NORMALS,  THE  RAY  TUBE  AREA  TERMS,  AN 
THE  AGE(S) .  IF  RAY  TRACE  PRINTING  IS  SELECTED,  ALSO  PRINTS  A  RECORD  0 
POSITION,  RAY  TUBE  AREA,  AND  TIME  AT  SELECTED  ALTITUDES. 

THE  ALTERNATE  RETURN  IS  TAKEN  IF  THE  RAY  STARTS  CURVING  UPWARD. 

PARAMETERS  :  NAME  TYPE  PURPOSE 

INPUT  :  NONE 

OUTPUT  :  RCBLG  L  FLAG  SET  IF  THE  RAY 

A  RECURVATURE  POl 
BELOW  THE  GROUND 
ABOVE  -1000  FT 


LOGICAL  RCBLG 


COMMON  /ATMCON/  REARTH,GO,RSTAR,ROMO,ROGOMO 


COMMON  / ACSPOT /  TIME ,XRO, YRO.ZRO.XDOT , YDOT , ZDOT , AIRSPD , ASPOOT , 

►  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

►  SINMU.EKC3, 3), EKDOT<3,3>,GLOAO,HEADIN, CLIMB, BANK, 

"  XDDOT , YOOOT , ZDOOT , XDDOOT , YDDDOT , ZDDDOT  • 

COMMON  /RAYVAR/  ZD  I R , PKK , RTPAAO , ATTEN , S I GMA , X , Y , Z , DAGE , XF , YF , ZF , 
k  XT,YT,ZT,XS,YS,ZS,XSS,rSS,ZSS,XSSS,rSSS,ZSSS,P3, 

’  P3F,P3T,P3S,XFS,YFS,XTS,YTS,ZFTP3,XFTZ,YFTZ,ZFTZ, 

'  ZFA,ZTA,P3FTZ,P3FA,P3TA,AREA,DAGDS 

REAL  SIGMA, X,Y,Z, DAGE, XF,YF,ZF, XT, YT,ZT 
REAL  XK(3) ,XKF(3) ,XKT(3) 

REAL  XKS(3),XKFS(2),XKTS(2) ,XKFTZ(3) ,XKSS(3) ,XKSSS(3) 

EQUIVALENCE  <XK( 1 ) ,X) , (XKF< 1 ) ,XF) , (XKTC1 ),XT), (XKSC 1 ) ,XS) 
EQUIVALENCE  (XKFSC 1 > ,XFS) , <XKTS< 1 ),XTS) , (XKFTZI 1 > ,XFTZ) 
EQUIVALENCE  (XKSS(1 ) ,XSS), (XKSSSC1 ) ,XSSS) 

COMMON  /RAYHLD/  HSIGMA, MX, HY, HZ.HDAGt ,nXF , HYF, HZF , HXT, HYT, HZT , 
HXS,HV$,HZS,HXSS,HYSS,HZSS,HXSSS,HYSSS,HZSSS, 

HP3 , HP3F, HP3T , KP3S, HXFS, HYFS, HXTS, KYTS, HZFTP3 , 
HXFTZ,HYFTZ,HZFTZ,HZFA,HZTA,HP3FTZ,HP3FA,HP3TA, 
HAREA, HDAGOS 

REAL  HSIGMA , HX, HY , HZ , HOAGE , HXF , HYF , HZF , HXT , HYT , HZT 
REAL  HXKC3) , HXKF(3) , HXKT (3 ) 


REAL  H8VR(1 1 ),H8HD( 11 ),D£LZ 

REAL  HXKS<3) , HXKFS<2) , HXKTS(2) , HXKFTZC3 ) , HXKSSC3) , HXKSSS(3) 

REAL  HOLO  VR  (  28  ) ,  HOLD  HO  <  28 ) 

EQU I VALENCE  <  HOLD VR{ 1 ) , XS ) , ( HOLD HO ( 1 ) , HXS ) 

EQUIVALENCE  (H8VR(1 ), SIGMA) , (H8HD<1 ) .HSIGMA) 

EQUIVALENCE  (HXK( 1 ) , HX) , (HXKF ( 1 ) , HXF) , (HXKT ( 1 ) , HXT) , (HXKS( 1 ) , HXS) 
EQUIVALENCE  (HXKFSL1 ),HXFS) , (HXKTS(I), HXTS), (HXKFTZ( 1 >, HXFTZ) 

EQU I  VALENCE  ( HXKSS ( 1 ) , HXSS ) , ( HXKSSS( 1 ) , HXSSS ) 

COMMON  /CLASES/  CNAM£S<30) 

CHARACTER'S  CNAMES 

COMMON  /CLASSS/  NRCURV<2, 2), TYPRAr<3, 2, 2), DIRECT, LOFT, UP, DOWN 
LOGICAL  TYPRAY, DIRECT, LOFT, UP, DOWN 

COMMON  /RYCTRL/  NORAYS, STNO ,UL , UR ,LL,LR, PRTRAY, TIM8EG.DELTIM, 

♦  NTIMS, PHIBEG, DELPHI ,NPHIS 
LOGICAL  NORAYS , STNO , UL , UR , LL , LR , PRTRAY 

COMMON  /RAYN I T/  KGMH , NOCRVS , NUCR VS , I UPOWN , TO , PH 1 0 , XO , YO , ZO , 

♦  P10,P20,P3Q, OMEGA, OELTAO, PI F0,P2F0,P3F0,0MEGAF, 

♦  XTQ , YTO , ZTQ , PI TO , P2TO , P3T0 , OMEGAT , XSO , YSO , ZSO, 

♦  P3S0 , RHOO , PCONST , NAGES , AGE  S( 20 ) 

I NTEGER  KGMH , NOCRVS , NUCRVS , IUPOWN 

REAL  PK(2),PKF(2),PKT<2) 

EQUIVALENCE  (PK(1 ),P10), (PKF< 1 ) ,P1FO) , (PKT(1 ) ,P1T0) 

COMMON  /ATMSPH/  GAM,C,U,V,DCOZ,DUOZ,OVOZ,D2COZ2,D2UOZ2,D2VDZ2,RHO 
REAL  GAM ,  C ,  U ,  V 

COMMON  /GROUND/  GLAYER , ZGRNO , CGRNO , UGRND , VGRND , REFLFC 
INTEGER  GLAYER 

COMMON  /LYROEF/  NLAYER,GMZA(200), INDPTHC200), INDWND(200), 

♦  LYRPRT ( 200 ) , KLAYER , ZTOP , ZBOT 
LOGICAL  LYRPRT 

REAL  TIMCVR,TPRINT 
INTEGER  INOPTH, INDUND 

COMMON  /CAUSTC/  NUMC, TRACE , CT(360) , CPH I (360) ,CXYZ(360,3) 

REAL  CXYZ 

LOGICAL  TRACE 

COMMON  /RPOSN/  NPTR, CPOSN , RTC200) ,RXYZ(200,3) , RAGEI200) , 

♦  RPFACT(200),RVLIFT,REMEM 

REAL  RT.RXYZ, RAGE, RPF ACT 

INTEGER  NPTR, CPOSN 
LOGICAL  REMEM 

LOGICAL  PTHOR 
COMMON  /JJJ/  PTHOR 


LOGICAL  CFLAG.GFLAG 
REAL  I  FACT 


IF  (GFLAG)  THEM 
I  FACT  •  17. 

ELSE 

I  FACT  *  1.5 
END  IF 

PTHDR  *  .TRUE. 

RCBLG  *  .FALSE. 

CFLAG  *  .FALSE. 

NDCRVS*0 

NUCRVS*0 

KGM*»1 

1  CONTINUE 

DO  2  1*1,28 

HOLDHD(L)*HOLDVR(l) 

2  CONTINUE 
DO  3  L*1 ,11 

H8HO ( L }*H8VR ( L ) 

3  CONTINUE 
TDLSIG*.30 

C 

C-  CHECK  FOR  RAY  CURVING  UP 
C 

IF  (2DIR.GT.0.)  RETURN  1 

IF  <ZS+ZS$*TOLSIG.GT.O.)  TOLSIG*ANAXl (0. , -ZS/ZSS) 

DELZ=AMAX1 ( -50.0, Z80T-Z, AMIN1 ( -1.0, <ZS+.50*ZSS*TDLSI G)*TDLSIG) ) 
IF  (DELZ.LT.Q.O)  GO  TO  15 
IPRNT»KLAYER 
KLAYER*KLATER-1 
C 

C-  CHECK  FOR  RAY  AT  GROUND  *  1000  FT 
C 

IF  (KLAYER.LE.O)  GO  TO  451 
C 

C-  CHECK  FOR  RAY  AT  GROUND 
C 

IF  ( KLAYER . EO . GLAYER ■ 1 )  GOTO  450 
GO  TO  400 

10  IF  (ZS+ZSS*TDLSIG.LT .0. )  TDLSIG*AMAX1 (0, , -ZS/ZSS) 

DELZ*AMIN1(50.0,ZTOP-Z, ANAX1 (1.0, (ZS+.50*ZSS*TDLS1G)*TDLSIG) ) 

IF  (DELZ.GT.0.0)  GO  TO  15 
KLAYER*KLAYER*1 

lprnt=klayer 

IF  (KLAYER. OE.NLAYER)  GO  TO  500 
GO  TO  400 


15  Z*HZ*OELZ 


IF  (Z.LT. ZGRND  '  IFACT*304.8)  GOTO  451 

CALI  RATES <*320 ,*300) 

CALL  AOVANS(CFLAG) 

C 

C-  IF  A  CAUSTIC  IS  ENCOUNTERED  BELOW  500  FT  AND  WE  ARE  LOOKING  FOR 
C-  THE  FOCUS  THEN  CONTINUE  ELSE  GO  ON  TO  THE  NEXT  RAT 
C 

IF  ( CFLAG . AND . Z . L£ . ZGRNO+304 . 80 )  THEN 
IF  (TRACE)  THEN 
Z  *  Z 
ELSE 
RETURN  1 
ENOIF 
ENOIF 
GO  TO  1 

300  CALL  RCRV1T 

305  CALL  RATES(*320 , *420 ) 

320  CALL  ADVANS(CFLAG) 

IF  (CFLAG. AND. Z.LE.ZGRND+304. 80)  THEN 
IF  (TRACE)  THEN 

z  «  z 

ELSE 

RETURN  1 
ENOIF 
ENOIF 

IF  ( .NOT .PRTRAY)  GO  TO  315 
C  WRITE(7,310) 

C  310  FORMAT ( 1  RECURVATURE  POINT  ATTAINED.') 

TPRINT*TIMCVR(SIGMA,2) 

ELEV=PHELEV(0. ) 

C  WRITE(7,60)  TPRINT.X.Y.Z.PS.ELEV.C.ZS.AREA.DAGE 
315  IF  (ZDIR.LT.O.)  GO  TO  350 
ZOIR*- 1 . 

N0CRVS=N0CRVS+1 

KGMH*2 

IF  (Z.GT.70E3)  KGMH*3 

C  CALL  RCSPCL ( 1  RAY  HIGH' , SIGMA, XK,P3,XKF,XKT,XKS, AREA) 

IF  (NOCRVS.GT .NRCURV(3* IUPOWN , KGMH- 1 ) )  RETURN 
GO  TO  1 
C 

C-  RECURVATURE  BELOW  -1000  FT 
C 

350  IF  (Z . LE . ZGRND • I FACT*304 ,8)  GO  TO  451 
C 

C-  RECURVATURE  BETWEEN  0  &  -1000  FT 
C 

IF  (Z.LE.ZGRNO)  THEN 
IF  (Z.EO. ZGRND)  THEN 


TPRIMT»TIMCVR<SIGMA,2J 

ELEV«PHELEV(0.) 

C  IF  (PRTRAY)WRIT£(7,60)  TPRINT,X,Y,Z,P3,ELEV,C,ZS, AREA, CAGE 

NUCR VS=NUCR VS+ 1 

C  CALI  RCSPCLC  GROUND  1 , SIGMA, XK,P3,XICF,7ifT.XKS, AREA) 

CALL  RECORD (*600) 

END  IF 

600  RC8LG  *  .TRUE. 

RETURN 
END  IF 
C 

C-  RECURVATURE  ABOVE  THE  GROUND 
C 

NUCRVS=NUCRVS+ 1 

C  CALL  RCSPCLCRAY  LOW  ', SIGMA, XK,P3,XKF,XKT,XKS, AREA) 

C  VR!TE(7,355) 

C  355  FORMAT ( 1  RAY  RECURVING  UPWARD;  WILL  NEVER  TOUCH  GROUND.') 
RETURN  1 

IF  (Z-ZGRNO.GE.1.)  RETURN 
GO  TO  (370,380,380) ,KGMH 
370  IF  (LOFT)  GO  TO  480 
RETURN 

380  IF  (NDCRVS.GE.NRCURV(3-IUP0UN,KGMH-1))  RETURN 
GO  TO  480 

400  ZBOT *GMZA(KLAYER ) 

ZTOP=GMZA(KLAYER+1 ) 

CALL  RATES(*410,*420) 

FCTJMP-(P3S-HP3S)/ZS 
P3F*HP3F+ZF*FCTJMP 
P3T  *HP3T+ZT*FCT  JMP 

C  IF  ( . NOT . ( LYRPRT ( LPRNT ) .AND . PRTRAY ) )  GO  TO  1 
C  TPRINT«TIMCVR(SIGMA,2) 

C  ELEV«PHELEV(0.) 

C  WRITE(7,60)  TPR I  NT , X , Y , Z , P3 , ELEV , C , ZS , AREA , DAGE 
C  60  FORMATdX, F10.1 ,3F10.0, G10.3, F6. 1 ,2F10. 1 , 2G10.4) 

GO  TO  1 

410  IF  (ZDIR.LT.O.)  GO  TO  350 
KLAYER*KLAYER- 1 
ZBOT«GMZA(XLAYER) 

ZTOP«GMZA(KLAYER+1) 

GO  TO  305 

420  WRITE(7,421) 

421  FORMAT ( 1  IMPROPER  RETURN  FROM  RATES  IN  RAYTRK 1 ) 

RETURN 

C 

C-  OUTPUT  GROUND 
C 


450  TPRINT*TI MCVR ( S I GMA , 2 ) 


£LEV«PHELEV(0.) 

C  IF  (PRTRAY)WRITE(7,60)  TPRINT,X,Y.Z,P3,ELEV,C,ZS,AREA,DAG£ 
NUCRVS»NUCRVS+1 

C  CALL  RCSPCLC '  GROUNO  1 , SIGMA, XK,P3,XKF,XKT,XK$, AREA) 

CALL  RECORD(*452) 

452  GOTO  400 

C 

C-  OUTPUT  GROUNO  •  1000  FT 
C 

451  TPRINT«TIMCVR(SIGMA,2) 

ELEV*PHELEV(0. ) 

C  IF  (PRTRAY )WR 1 TE( 7, 60 )  TPRINT,X,Y,Z,P3,ELEV,C,ZS, AREA, CAGE 

C  CALL  RCSPCLC  G-1000  • .SIGMA, XK,P3,XKF,XKT,XKS, AREA) 

RETURN 

C 

C . 

C-  MUST  MAKE  PROVISION  FOR  TRACING  OF  OTHER  THEN  G  RAYS  HERE 
C-  IF  THAT  IS  TO  BE  ADDED 

C . 

c 

480  ZDIR*1 . 

KLAYER*1 

IF  (ZS.EO.O.)  GO  TO  495 

FCT  JHP*2 . *HP3S/ZS 

P3F=- HP3F+FCT  JMP*HZF 

P3Ta-HP3T+FCTJMP*HZT 

ZF=-HZF 

ZT**HZT 

AREA»-HAREA 

ATTEN=>ATTEN*REFLFC 

CALL  RATES (*495, *420) 

IF  (PRTRAY)URITE(7,490) 

490  FORMAT ( '  •******»****•*  REFLECTING  FROM  GROUND  ***** 
GO  TO  1 

495  IF  (PRTRAY )WR I TE  (6,496) 

496  FORMAT ( 1  ******«*RAY  TANGENT  AT  GROUND  LEVEL*********') 

GO  TO  1 

500  IF  (PRTRAY )WR I TE ( 6 , 505 ) 

505  FORMAT ('  STOPPING  AT  TOP  OF  ATMOSPHERE.') 

RETURN 

END 


c 


SUBROUTINE  RATES(*,*) 


C 

C  RATES  COMPUTES  THE  LOCAL  RATE  OF  CHANGE  OF  THE  RAY  POSITION,  THE  RAY 
C  NORMALS,  ANO  THE  ASSOCIATED  DERIVATIVES  WITH  RESPECT  TO  THE  RAY 
C  PARAMETERS  PH!  ANO  EMISSION  TIME. 

C 


COMMON  /RAYNIT/  KGMH , NOCRVS , NUCRVS , I UPOUN , TO , PH 1 0 , XO , YO , ZO , 

♦  P10,P20,P30, OMEGA, DELTAO,P1FO,P2FO,P3FO,OMEGAF, 

+  XTO,YTO,ZTO,P1TO,P2TO,P3TO,OMEGAT,XSO,YSO,ZSO, 

♦  P3S0, RHOO, PCONST , SAGES , AGES (20) 

INTEGER  KGMH ,NDCRVS,NUCR VS, 1 UPOUN 

REAL  PK(2) ,PKF<2) ,PKT(2) 

EQUIVALENCE  (PK(1 > , P10>, <PKF< 1 ) ,P1FO) , <PKT< 1 ) ,P1TO) 

COMMON  /RAYVAR/  ZOIR,PKK,RTPAAO,ATTEN,SIGMA,X,Y,Z,DAGE,XF,YF,ZF, 

♦  XT , YT , 2T , XS , YS , Z3 , XSS , YSS , ZSS , XSSS , YSSS , ZSSS , P3 , 

♦  P3F,P3T,P3S,XFS/YFS,XTS,YTS,ZFTP3,XFTZ, YFTZ,ZFTZ, 

♦  ZFA, ZTA, P3FTZ , P3FA , P3TA, AREA , DAGOS 
REAL  XKS(3),XKFS<2),XKTS(2),XKFTZ(3),XKSSC3>,XKSSSC3) 

REAL  SIGMA, X.Y.Z, CAGE, XF,YF,ZF, XT, YT,ZT 

REAL  XK(3),XKE(3>,XKTf3) 

EQUIVALENCE  (XK(1 ) ,X) , <XKF<1 ) ,XF) , <XKT( 1 ) ,XT) , (XKS(1 ) ,XS) 
EQUIVALENCE  (XKFS( 1 ) ,XFS) , (XKTS(1 },XTS) , (XKFTZI 1 > ,XFTZ) 
EQUIVALENCE  (XKSS( 1 ) ,XSS) , (XKSSS( 1 ) ,XSSS) 

COMMON  /ATMSPH/  GAM,C,U,V,DCOZ,OUOZ,OVOZ,D2COZ2,D2UDZ2,D2VDZ2,RHO 
C  REAL  UK(2)  GARBAGE 

REAL  UK(2),DUKDZ(2),D2UKDZ(2) 

REAL  GAM , C , U , V 

REAL  OOELTA.RTPKK 

EQUIVALENCE  (UK< 1 ) ,U) , <DUKDZ( 1 ) , DUOZ) , <02UKDZ( 1 ) , D2UDZ2) 

C 

c 

CALL  AIR(Z) 

D0ELTA*(OMEGA)-U*<P10)-V*<P20) 

D£LTA*OOELTA 

RTPKK*OOELTA/C 

PKK*RTPKK**2 

IF  ( RTPKK . LT . RTPAAO )  RETURN  2 
CSQOO=C*C/OOELTA 

P3=SQRT< (RTPKK- RTPAAO)*(RTPKK+RTPAAO> ) 

P3=SI GN(P3 , 2D  I R  > 

ZS=P3*CSOOO 
DO  20  K=1 ,2 

XKS(K)=CSQOO*PK(K)+UK(K) 

20  CONTINUE 


OELTAF*OKEGAF-U*P1FO-V*P2FO 

DELTAT*OMEGAT-U*P1TO-V*P2TO 

0EITAZ«-<P10*DUDZ+P20*DVDZ) 

OLTAZZ**<P10*02UDZ2+P20*02VDZ2) 

01N01Z*0ELTAZ/DELTA 
D2LNDL=0LTAZZ/DELTA-DINDLZ**2 
DlNCDZ=OCDZ/C 
02LCOZzO2COZ2/C*DLMCOZ**2 
CSQOOZ«CSaOO*(2. *0LNCD2 -OLNOLZ) 

CSQOZZ*CSOOOZ*(2.*DLNCOZ-DINDIZ)+CSOOO*(2.*D2L.CDZ-D2LNDI) 

P3S»OELTA*(DLNDLZ-OLMCOZ) 

P3SZ*-DEITA*D2LCDZ-0ELTAZ*OINCDZ+OLTAZZ 

ZSS«CSOCO*P3S+CSQOOZ*P3*ZS 

P3SS»P3SZ*ZS 

ZSSS»CSOCO*P3SS*2 . *CS000Z*P3S*ZS+ 

♦  P3*(CSQDZZ*ZS*ZS+CS000Z*ZSS) 
P3TA«-(P1T0*0UDZ+P2T0*DVD2)-D£LTAT*DLNCD2 
P3FA*-<P1FO*OUOZ+P2FO*DVDZ)-DEITAF*OLNCDZ 
P3FTZ*P3SZ 

ZFTP3*CSQ00 
ZFTZ*P3*CSQ00Z 
ZFA*- 0ELTAF*P3/PKK 
ZTA* • CELT AT*P3/PKK 
DO  40  K=1,2 

XKFTZOOxOUKDZ  flO+CSQ00Z*P)C()O 
XKFSOC  WFTP3*PICF<IC)  •  PK(K)*0E1.TAF/PKX 
XKTS<K)«ZFTP3*PKT(K)-PK(IO«t>ELTAT/P)CK 
XKSS(K)«ZS*(CSQOOZ*PK(IO*OU«)Z(K)) 

XKSSSOC  )=»ZSS*  <  CSQOOZ*PK(IO*OUKDZ(K  >  )* 

*  ZS*ZS»<CS0DZZ*PK<K)+02UKDZ<IO> 

40  CONTINUE 

c* •*•«•*•*■*•**»•*»*•*■* 

C  DAGDS»PCONST*.5*(1.*GAM)*(((RTPKK)/DELTAO)**1.5)/SQRT(RHO) 
DAGOS*PCONST*.5*(1.+GAH)*<DElTA**1.5)/C/SQRT<RHO> 

IF  (ZS.EQ.O.)  RETURN  1 

RETURN 

END 


SUBROUTINE  ADVANS(CFLAG) 


C 

c 

c 

c 

c 

c 


AC VANS  UTILIZES  INFORMATION  FROM  RATES  TO  COMPUTE  ADVANCE  IN  CURRENT 
TIME,  AND  THE  CHANGE  IN  RAT  POSITION  AND  ASSOCIATED  VARIABLES 
CORRESPONDING  TO  IT. 


COMMON  /RYCTRL/  NORATS , STND , UL , UR , LL , LR , PRTRAY , T I MBEG , CELT  I M , 

♦  NTIMS.PHIBEG, DELPHI ,NPH!S 
LOGI CAL  NORATS , STND , UL , UR , LL , LR , PRTRAT 

COMMON  /GROUNO/  GLAYER , 2GRND , CGRND , UGRND , VGRND , REFLFC 
INTEGER  GLATER 

COMMON  /RAYNIT/  KGMH,NDCRVS,NUCRVS, IUPOUN,TO,PHIO,XO,YO,ZO, 

♦  P10,P20,P30, OMEGA, DELTA0,P1F0,P2F0,P3F0,0MEGAF, 

♦  XTO , TTO , ZT J , PI TO , P2T0 , F3T0 , OMEGAT , XSO , TSO , ZSO , 

♦  P3SO ,  RHOO ,  PCONST ,  ;.AGES , AGESC20 ) 

INTEGER  KGMH , NOCRVS , NUCRVS , IUPDWN 

REAL  PKO(2),PKFO<2),PKTO(2) 

EQUIVALENCE  (PKO< 1 ) , PIO) , (PKFO< 1 ) ,P1FO) , (PKTOO , ,P1TO) 

COMMON  / ACSPOT /  TIME,XRO,YRO,ZRO,XDOT,YDOT,ZDOT,AIRSPD,ASPDOT, 

+  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU,EK(3,3),EKDOT(3,3),GLOAD, HEAD  IN, CLIMB, BANK, 

+  XDDOT , TDOOT , ZDOOT , XDDDOT , YDDOOT , ZDDDOT 

REAL  XKRO<3) ,XKDOT (3) 

EQU I VALENCE  <XKR0< 1 ) , XRO ) , (XKDOT < 1 ) , XDOT ) 

COMMON  ,/ATMSPH/  GAM , C, U, V.DCDZ ,OUDZ ,DVD2 , D2CDZ2 .D2UDZ2 ,D2VDZ2, RHO 
REAL  GAM,C,U,V 

COMMON  /RAYVAR/  ZDIR, PKK, RTPAAO.ATTEN , SIGMA, X, Y,Z,DAGE,XF , YF,ZF, 

♦  XT , YT , ZT ,XS , YS , ZS , XSS , YSS , ZSS , XSSS , YSSS , ZSSS , P3 , 

♦  P3F , P3T , P3S , XFS , YFS , XTS , YTS , ZFTP3 , XFTZ , YFTZ , ZFTZ , 

♦  ZFA , ZTA , P3FTZ , P3FA , P3TA , AREA , DAGOS 
REAL  XKS<3),XKFS(2),XKTS<2),XKFTZ(3),XK$S(3),XKSSS<3) 

REAL  SIGMA,X,Y,Z,DAGE,XF,YF,ZF,XT,YT,ZT 

REAL  XK(3) ,XKF(3),XKT (3) 

EQUIVALENCE  <XK( 1 ) ,X) , (XKF< 1 ) ,XF) , (XKT( 1 ) ,XT) , (XKS( 1 ) ,XS) 
EQUIVALENCE  <XKFS(1 ), XFS), (XKTS(1), XTS), (XKFTZ<1), XFTZ) 
EQUIVALENCE  (XKSS( 1 ) , XSS) , (XKSSSC 1 ) , XSSS ) 

COMMON  /GRAYVR/  GATTEN,GPFACT 

COMMON  /RAYHLD/  HSIGMA, HX , HY , HZ , HDAGE , HXF , HYF , HZF , HXT , HYT , HZT , 

♦  HXS, HYS, HZS, HXSS, HYSS, HZSS, HXSSS, HYSSS, HZSSS, 


+  HP3 , HP3F , HP3T , HP3S , HXFS , HYFS , HXTS ,  HYTS , HZFTP3 , 

+  HXFTZ,HYFTZ,HZFTZ,HZFA,HZTA,HP3FTZ,HP3FA,KP3TA, 

*  HAREA ,  HDAGOS 
LOGICAL  TONE 

REAL  HXKSC3),HXKFS<2),HXKTS<2),HXKFTZC3),HXKSS<3),HXKSSS<3> 

REAL  RS(3) 

REAL  HS1GMA,HX,HY,HZ,H0AGE,HXF,HYF,HZF,HXT,HYT,HZT 
REAL  HXXC3) ,HXKF(3) , HXKT  <35 

REAL  TPRINT.TIMCVR 
REAL  RF<3),RT(3),RX(3),S1G 

EQUIVALENCE  <HXK<1 ) ,HX) , <HXKF< t ),HXF), <HXKT(1 >,HXT), <HXXS(1 >,HXS> 
EQUIVALENCE  (HXKFSO ), HXFS), (HXKTS(I), HXTS), (HXKFTZd ) ,HXFTZ) 
EQUIVALENCE  (HXKSSC 1 ) , HXSS) , ( HXKSSSC 1 ) , HXSSS) 

COMMON  /CAUSTC/  NUMC , TRACE , CT ( 360 ) , CPH I ( 360 ) , CXYZ  C 360 , 3 ) 

REAL  CXYZ 
LOGICAL  TRACE 

COMMON  /RPOSN/  NPTR , CPOSN , RTT( 200) , RXYZ( 200,3) ,RAGE<200) , 

♦  RPFACT(200),RVL1 FT, REMEM 

REAL  RTT , RXYZ , RAGE , RP  F  ACT , R VL I  FT 

INTEGER  NPTR, CPOSN 

LOGICAL  REMEM 

LOGICAL  OPSIGN.CFLAG 
DATA  MAXR/200/ 

OPSIGN<Ar8)*<<A.LT.O.).ANO.C8.GE.O.)).OR.CCA.GT.O.).AND.(B.LT.O.)> 

CFLAG  =  .FALSE. 

AA*ZHZ 

BB=.5*(ZS+HZS) 

CC=<ZSS-HZSS)/10. 

00=<ZSSS+HZSSS)/120. 

IF  (AA.EQ.Q. )  RETURN 
DELSIG*AA/8B 
DO  10  X*1,5 

ENUM*< ( • OO'DELS I G+CC ) *0EL  S I G- SB )*DELS I G+AA 
DEN*( •3.*D0*0ELSIG+2.*CC)*0ELSIG'BB 
IF  (DEN*AA.GE.O. )  GO  TO  12 
DELSIG*OELSIG-ENUM/DEN 
10  CONTINUE 
GO  TO  IS 
12  URITEI7, 14) 

14  FORMAT ( 1  TDLSIG  TOO  LARGE.') 

15  SIGMA=HSIGMA*DELSIG 
H0LSIG=.5*0ELSIG 
DLSIG6=DELSIG/6. 

00  20  IC=1 ,2 

XK(K)=HXK(K)*( ( (XKSSS<K)*HXKSSS(K) )*0ELSI G/1 2. ■ 

&  (XXSS(K) • HXKSS(K) ) )*DELSI G* .2*(XKS(K)+HXKS(K) ) )*HDLSI G 
20  CONTINUE 

EM  11  =  1 . -DLSIG6*(2.*ZFTZ+HZFTZ> 


EM12*-0LSIG6*(2.*ZFTP3*HZFTP3) 

EM21*-DISIG6*(2.*P3FTZ+HP3FTZ) 

EM22=1 . 

0£T*EN11*EM22-EN12*EM21 

HEM1 1*1 -*DLSIG6*(ZFTZ*2.*HZFTZ) 

HEM12*OLSIG6*(ZFTP3+2.*HZFTP3) 

HEM21=0LSIG6*(P3FTZ+2.*HP3FTZ) 

HEM22*1 . 

AZ*HEM11*HZF*HEM12*HP3F*H01SIG*(ZFA+HZFA) 

BZ*HEM21 *HZF*HEM22*HP3F+HDLS I G* ( P3F A+HP3FA) 
ZF*(EM22*AZ-£M12*8Z)/0ET 
P3F«< - £M21*AZ+EH1 1*8Z)/DET 
AZ*HEM11*HZT*HEM12*HP3T+HDLS1G*(ZTA*HZTA) 

8Z*HEM21 *HZT+HEH22*HP3T+H0LS 1 G*(P3TA*HP3TA > 

ZT  * ( EM22*AZ - EMI 2*BZ ) /OET 
P3T*( •EM21*AZ+EM11*8Z)/DET 
00  40  K*1,2 

XKF(K)*HXKF(K)*H0LS1G*(XKFS(K)+HXKFS(K) )*0LS1 G6* 

&  (ZF*(2.*XKFTZ(K)*HXKFTZ(K))*HZF*(XKFTZ(IO*2.*HXICFTZ(IO)) 

XKT(K)=HXKT(K)*HDIS1G*{XKTS(K)*HXKTS(K))+01SIG6* 

&  (ZT*(2.*XXFT2(X)*HXKFTZ(X))*HZT*(XKFTZ(K)+2.*HXKFTZ(IO) ) 

40  CONTINUE 

AREA*ARTU8E (P3 , XKF , XKT ) 

C  PFACT*PCONST*C*SQRT ( RHO*RTPKK/ (DELTAO* ( A8S( AREA )♦  1 .  E  •  1 2  )  ) ) 

ARFCT=SQRT (ABS(AREA)*1 .E- 12) 

HARFCT*SORT (ABS(HAREA )*1 .£• 12) 

IF  ( OPS  I GN ( HAREA , AREA ) )  GO  TO  70 

DAGE*HDAGE*ATTEN»OEL  SI G*(DAGOS* (  2 . *HARFCT*ARFCT)*HDAGDS* 

♦  (HARFCT*2.*ARFCT))/(1 . 5*(ARFCT*HARFCT)**2) 

C 

C-  SAVE  RAY  PARAMETERS 

C 

IF  (  Z .  IE . (ZGRNO )*762 . 0 )  THEN 

IF  (NPTR.IT.MAXR)  NPTR  *  NPTR  ♦  1 
00  1011  X  =  1,3 

RXYZ(NPTR.X)  *  XK(X) 

1011  CONTINUE 

RTT(NPTR)  *  SIGMA 
RAGE (NPTR)  *  OAGE 

Qs- I-3-3* 

C  PF ACT *PCONST*C*SORT <RHO*RTPKK/ (DELTAO* (ABSC AREA)* 1 .E- 12))) 

PFACT*PC0NST*C*SQRT(RH0*C*SQRT(PKK)/(ABS(AREA)*1.E-12)) 
PFACT*PFACT*ATTEN*(1.*REFLFC> 

RPFACT(NPTR)  *  PFACT 
EMOIF 

IF  (Z.EO. ZGRNO)  THEN 
GATTEN  *  ATTEN 
GPFACT  =  PFACT 
END  IF 

RETURN 

C 

C-  CAUSTIC  ENCOUNTERED 


c 


70  AR1*HAREA 
AR2=AREA 
TONE=AR2.GT.AR1 
TAU1=0. 

TAU2=1 . 

100  TAU=.5*(TAUUTAU2) 

TAUPR*1 . • TAU 
DO  110  K=1 ,3 

RF(K)*HXKF(IO*TAUPR+XKF()0*TAU 
RT  ( K  )  *HXKT  ( K)*T  AUPR+XKT  ( K ) *T AU 
110  CONTINUE 

PZ*TAUPR*HP3+TAU*P3 
IF  (TAU2-TAU1.LT.1.E-6)  GO  TO  160 
ARM= ARTUBE ( PZ , R  F , RT ) 

IF  (ARM)  120,160,140 
120  IF  (TONE)  GO  TO  150 
130  TAU2=TAU 
GO  TO  100 

140  IF  (TONE)  GO  TO  130 
150  TAU1*TAU 
GO  TO  100 

160  SIG=TAUPR*HS1GMA+TAU*S I GMA 
DAGE=HOAGE 

IF  (HAREA.NE.O.)  OAGE=HOAG£+ATT£N*OLSIG6»8.*(HDAGOS*( 1 .5- TAU)+ 
+  DAGOS*TAU)*TAU/HARFCT 
00  170  K=1,3 

RK(K)=TAU*XK(K)-«-TAUPR*HXK(X) 

RS(K)=TAU*XKS(K)+TAUPR*HXKS(K) 

170  CONTINUE 

IF  ( .NOT .PRTRAY)  GO  TO  200 
C  WRITE(7, 180) 

180  FORMAT ( 1  CAUSTIC  POINT  CROSSED.') 

TPR1NT*TIMCVR(SIGMA,2) 

ELEV=PHELEV(0.) 

C  URITE(7, 190)  TPRINT,X,Y,Z,P3,ELEV,ZS,0AGE 

190  FORMAT( IX, F10. 1 ,3F10.0, G10.3, F6. 1 , 10X, F10. 1 , 2X, '0. ' ,6X, G10.4) 

200  CONTINUE 

CALL  RCSPCLC CAUSTIC  '  ,SIG,RX,PZ,RF,RT,RS,0. ) 

C 

C-  SAVE  THE  POSITION  OF  THE  CAUSTIC  WHEN  NOT  LOOKING  FOR  THE  FOCI 
C 

IF  (NUMC.LT.360)  NUMC  *  NUMC  ♦  1 
CPHI(NUMC)  =  PHIO 
CT(NUMC)  *  SIG 
00  1010  K  *  1,3 

CXYZ(NUMC,K)  =  RK(K) 

1010  CONTINUE 

AGES(NAGES)=OAGE 

NAGES=NAGES+1 

0AGE=0.0 

IF  (Z.lE. (ZGRN0)*762 ,00)  THEN 


IF  (NPTR.LT.MAXR)  MPTR  *  MPTR  ♦  1 
CPOSN  *  MPTR 
DO  1012  <  *  1,3 

RXYZ(NPTR,IO  «  RKOO 

1012  CONTINUE 
RTT(NPTR)  *  SIG 
RAGE(NPTR)  *  DAGE 
RPFACT(NPTR)  *  0.00 

ENOIF 

IF  (AREA. ME. 0.)  DAG£*ATTEN*0LSIG6»8.*CDAGDS*(1 .5-TAUPR)* 
+  HOAGOS«TAUPR)'TAUPR/ARFCT 

CFLAG  ■  .TRUE. 

IF  (XK(3) .EQ.ZGRNO)  THEN 

IF  (NPTR.LT.MAXR)  MPTR  *  MPTR  1 
DO  1013  X  *  1,3 

RXYZ(NPTR,K)  *  XK(K) 

1013  CONTINUE 
RTT(NPTR)  *  SIGMA 
RAGE (MPTR)  *  CAGE 
RPf ACT(MPTR)  »  PFACT 

END  IF 

IF  (Z.EQ.ZGRND)  THEN 
GATTEN  «  ATTEN 
GPFACT  «  PFACT 
EMOIF 

RETURN 

END 


SUBROUTINE  RCRVIT 


C 
C 

C==ass 

c==»= 
c 

c 

C  RCRVIT,  WHEN  A  TENTATIVE  ADVANCE  BRINGS  RAT  BEYOND  A  REVERSAL  LAYER, 
C  WILL  LOCATE  THE  EXACT  POSITION  OF  THE  REVERSAL  LAYER. 

C 


COMMON  /RAYNIT/  KGMH , NDCRVS , NUCRVS , IUPDUN , TO , PH 1 0 , XO , YO , ZO , 

+  P10,P20,P30, OMEGA, OELTAO, PI F0,P2F0,P3F0,0MEGAF, 

+  XTO , YTO , 2T0 , P1TO, P2T0 , P3T0 , OHEGAT ,XSO , YSO, 2S0 , 

♦  P3S0 , RHOO , PCONST , NAGES , AGESC20) 

INTEGER  KGMH, NDCRVS, NUCRVS, IUPOWN 

COMMON  /RAYVAR/  ZD IR ,PKX , RTPAAO, ATTEN , SIGMA, X, Y , Z ,DAGE ,XF , YF ,ZF , 

♦  XT , YT , ZT , XS , YS , ZS , XSS , YSS , ZSS , XSSS , YSSS , 2SSS , P3 , 

♦  P3F ,P3T,P3S ,XFS, YFS , XTS, YTS, ZFTP3.XFTZ, YFTZ, ZFTZ, 

♦  ZFA.ZTA, P3FTZ.P3FA , P3TA , AREA , D AGDS 

REAL  S I GMA , X , Y , 2 ,OAG£ , XF , YF , 2F , XT , YT , ZT 

COMMON  /ATMSPH/  GAM,C,U,V,DCDZ,DU02,DVDZ,D2CDZ2,D2UDZ2,D2VDZ2,RH0 
REAL  GAM , C , U , V 

COMMON  /RAYHLO/  HS I GMA , HX , HY , HZ , HOAGE , HXF , KYF , HZF , HXT , HYT , HZT , 

♦  HXS , HYS , HZS, HXSS , HYSS , HZSS , HXSSS , HYSSS , HZSSS , 

+  HP3 , HP3F , HP3T, HP3S, HXFS, HYFS , HXTS, HYTS , HZFTP3 , 

♦  HXFTZ,HYFTZ,HZFTZ,HZFA,HZTA,HP3FTZ,HP3FA,HP3TA, 

♦  HAREA.HOAGDS 

REAL  HSI GMA, HX , HY , HZ , HDAGE , HXF , HYF , HZF , HXT , HYT , HZT 
REAL  ZA , ZS , ZM I 0 

REAL  DOELTA.RTPKX 
C 

ZA=HZ 

ZB=Z 

5  ZMID=.50*(ZB+ZA) 

GG1  =  A8S(ZMID-ZA) 

GG2  *  ABS(ZMID-ZB) 

IF  (AMIN1 (ABS(ZMID*ZA) , ABSCZB- ZMID) ) .LT. 1 .E-4)  GO  TO  TOO 
CALL  AIR(ZMID) 

OOELTA=(OMEGA)-U*(P1O)-V*(P20) 

RTPKK=ODELTA/C 
XLXl  =  9TPKK-RTPAA0 

C  IF  (A8S(XLXL).LT.1 . OE - 6}  GOTO  90 

IF  (XLXL)  10,90,20 
10  ZB-ZMID 
GO  TO  5 
20  ZA=ZMID 


GO  TO  5 
90  Z»ZMID 
RETURN 
100  ZXZA 
RETURN 
END 


c 

c 


C3:SS3SSSS833338S3SS?S3«SSSX:S3SS3S:S33S%=SSSSS33XS£SSSSS3:SS1S3:£SS3SS= 

C=s3sss3ss3x33s»:s3si:ssss3s3ss:sss:ss2«:s3s3»s:==rs:sss2ssx:=2s2sss3s 

c 

SUBROUTINE  RECORDS) 

C 

C  RECORD,  WHEN  THE  RAY  HAS  BEEN  TRACED  TO  GROUNO  IN  A  SELECTED  CARPET, 

C  WILL  RECORD  THE  LOCATION  ANO  ALL  THE  ASSOCIATED  VARIABLES  REQUIRED 
C  TO  COMPUTE  SIGNATURES  ON  A  TEMPORARY  FILE  (FORTRAN  UNIT  9). 

C 

C 


COMMON  /ATMCON/  REARTH , GO , RSTAR , ROMO , ROGOMQ 

COMMON  /ACIDNT/  IDENT 
CHARACTER'8  IDENT 

COMMON  /ACWEIG/  ACUT.ACL 

COMMON  /CLASES/  CNAMES<30) 

CHARACTER'S  CNAMES 

COMMON  /CLASSS/  NRCURV<2, 2), TYPRAY(3, 2,2), DIRECT, LOFT, UP, DOWN 
LOGICAL  TYPRAY, DIRECT, LOFT, UP, DOWN 

COMMON  /GROUND/  GLAYER , 2GRND , CGRND , UGRND , VGRND , REFLFC 
INTEGER  GLAYER 

COMMON  /ACSPOT/  TIME, XRO , YRO , 2RO , XDOT , YDOT , ZDOT , A I RSPD , ASPDOT , 

♦  CO , UO , VO , COOT , XMACH , XMADOT , XMU , XMUDOT , COSMU , 

♦  SINMU, EK(3, 3) , EXDOT (3,3), GLOAD , HEAD  IN, CL IMB, BANK, 

♦  XDOOT , YDDOT , ZDOOT , XDDDOT , YDDDOT , ZDODOT 

COMMON  /ATMSPH/  GAM,C,U,V,OCDZ,DUDZ,DVDZ,D2CDZ2,D2UDZ2,D2VDZ2,RHO 
REAL  GAM , C , U , V 

COMMON  /RAYNIT/  KGMH , NOCRVS , NUCRVS , IUPDWN,T0,PHI0,X0,Y0,Z0, 

♦  P10,P20,P30, OMEGA, DELTAO, PI FO,P2FO,P3FO,OMEGAF, 

+  XTO , YTO, ZTO , PI TO , P2T0 , P3T0 , OMEGAT , XSO , YSO , ZSO , 

♦  P3S0 , RHOO , P CONST , NAGES , AGE  S( 20 ) 

INTEGER  KGMH, NDCRVS, NUCRVS, IUPDWN 

REAL  PK(2),PKF(2),PKT(2) 

EQUIVALENCE  <PK(1 ),P10) , (PKF<1 ),P1F0) , (PKT(1 ) ,P1T0> 

COMMON  /RAYVAR/  ZDIR, PKK,RTPAAO,ATTEN, S I GMA,X, Y, Z,DAGE, XF , YF ,ZF, 

+  XT , YT , ZT ,XS , YS , ZS, XSS, YSS, ZSS,XSSS , YSSS , ZSSS , P3 , 

+  P3F,P3T,P3S,XFS,YFS,XTS,YTS,ZFTP3,XFTZ,YFTZ,ZFTZ, 

♦  ZFA , ZTA, P3FTZ, P3FA, P3TA , AREA , DAGDS 
REAL  XKS(3 ) ,XKFS(2) , XKTS(2 ) ,XKFTZ(3) ,XKSS(3) , XKSSS(3) 

REAL  RX(3) ,RXF(3) ,RXT(3) 

REAL  SIGMA,X,Y,Z,DAGE,XF,YF,ZF,XT,YT,ZT 
REAL  XK(3),XKF(3),XKT(3) 


EQUIVALENCE  (XK(1) ,X) ,  (XKF(1 ) ,XF), (XKT(1 ),XT) ,  (XK$(1 ),XS) 
EQUIVALENCE  (XKFS( 1 )  ,XFS) , (XKTS(1),XTS) , (XKFTZ( 1 ) ,XFTZ) 
EQUIVALENCE  <XXSS< 1 ) ,XSS) , (XKSSS( 1 ) , XSSS ) 

c 

COMMON  /GRAYVR/  GATTEN , GPFACT 

DATA  DGPRAD/57. 295730/ 

C 

NCLAS*3 

IF  (KGMH.E0.1)  GO  TO  10 
NCLAS*2*(N0CRVS+3*{3 - KGMH*2* ( 2  ■  I  UPOUN ) )  )+3 
IF  (.N0T.TYPRAY(NDCRV$,3-IUP0WN,KGMH-1))  GO  TO  20 
GO  TO  15 

10  IF  (.NOT. DIRECT)  GO  TO  20 
C*-»— «-»-«-*-»— ■-* 

C  15  RTPKK*SQRT (PKX) 

15  DELTA  »  C»SQRT(PKK) 

. . . 

C  PFACT«PCONST*C*SaRT(RHO*RTPKK/(DELTAO«(ABS(AREA)+1 .E-12))) 

PFACT*PC0NST*C*SQRT(RH0*0ELTA/(A8S(AR£A)*1 .E-12)) 
PFACT*PFACT*ATTEN*(1 .♦REFLFC) 

VL 1 FT*ACUT*GLQAD*GO*COSHU*COS ( (PH 1 0 -  BANK )/DGPRAD )/ 

♦  (RHO0*SINMLr»AIRSP0*»2) 

RECPHI*AMOO(AMCO(PHIO,360. )*450. ,360. )-90. 

RSIGM»<SIGMA) 

DO  17  K*1 ,3 
RX(K)«XK(K) 

RXF(K)*XKF(K) 

RXT (K)=XKT (K) 

17  CONTINUE 

AGES(NAGES)=OAGE 
URITE(9,99)  CNAMES(NCLAS) 

99  FORMAT  (A8) 

UR  I TE (9, *)  KGMH , NOCRVS , IUP0WN , XMACH, VL I  FT , TO, RECPH I , 

♦RSIGM.RX, OMEGA, PK,P3,XKS, RXT ,RXF ,PFACT, NAGES, (AGES(K) ,K*1 , MAGES) 
20  IF  (KGMH.EQ.1)  GO  TO  30 

IF  ( NOCRVS. GE.NRCURV( 3- 1 UPOUN , KGMH - 1 ) )  RETURN 
RETURN  1 

30  IF  (LOFT)  RETURN  1 
RETURN 
END 


Os3a2SXa3S33aXSSSSa2Xia8l«t32SXS33Sa3SS«lS33X2SSS:33SSISSf83SXSS» 

c 

FUNCTION  ARTUB£(PZ,RF,RT) 

C 

C  ARTUBE  COMPUTES  THE  JAC08IAN  DEFINING  THE  RAY  TUBE  AREA. 

C 

COMMON  /RAYNIT/  KGMH,NDCRVS,NUCRVS, IUPDVN,TO,PHIO,XO,YO,ZO, 

♦  PIO.PZO.PSO.OMEGA.DELTAO.PIFO.PZFO.PSFO.OMEGAF, 

♦  XTO , YTO , ZTO , PI  TO , P2T0 , P3TO , OMEGAT , XSO , YSO , ZSO , 

♦  P3S0 , RHOO, PCONST ,NAGES , AGESC20) 

INTEGER  XGMH , NDCRVS , NUCRVS , IUPDUN 

INTEGER  INOET (3) 

REAL  P«2),PKF<2),PKT<2> 

REAL  RF<3) ,RT (3) 

EQUIVALENCE  (PX(1 ) ,P10) , <PXF(1 ),P1FO) , (PKT(1 > ,P1T0> 

OATA  INDET/2,3, 1/ 

C 

ARTUBE»PZ*(RF(1)*RT(2)-RF<2)*RT(1)> 

PKX»PZ**2 
DO  10  X-1,2 

ARTUBE*ARTUBE*PK(K)*(RF( INOET<K) )*RT( INDETCK+1 ) )- 
&  RF( INOET (K+1 ) )*RT ( INOET (X) ) ) 

PKK=PKX*PK(X)»*2 
10  CONTINUE 

C  ARTU8E=ARTUBE/SQRT(PKK) 

ARTUBE*ARTUBE/PXK 

RETURN 

END 


c 

c 

Cs******sxa**«**i**ai*M**M**MS«s3****M3*aa*SMMais»*aas**s=asss*a 

^3Xa3S«S»IISlllllSI«UaSMtSSSt83SBias3SSSISSXSStSaSSSStSISSS3SSSSS3SIX 

c 

SUBROUT  I NE  RCSPCL (T YPE , S 1 G , RK , PZ , R  F , RT , RS , AREA ) 

c 

C  RCSPCL  RECOROS  ON  A  TEMPORARY  FILE  (FORTRAN  UNIT  11)  THE  POSITIONS  AN 
C  TIMES  FOR  EACH  "SPECIAL  POINT"  IN  THE  RAY'S  PATH.  "SPECIAL  POINTS" 

C  INCLUDE  REVERSAL  LAYER  ENCOUNTERS,  GROUND  ENCOUNTERS,  AND  THE  ENCOUNT 
C  WITH  THE  CAUSTIC  SURFACES. 

C 

CHARACTERS  TYPE 

REAL  RK(3),RF<3),RT(3),SIG 

REAL  RS(3) ,AREA,RF4(3) , RT4<3) ,RK4<3) 

COMMON  /CLASES/  CNAMES(30) 

CHARACTER'S  CNAMES 

COMMON  /CLASSS/  NRCURV(2, 2) ,TYPRAY(3 ,2,2) .DIRECT , LOFT , UP, DOWN 
LOGICAL  TYPRAY, DIRECT, LOFT, UP, DOWN 

COMMON  /PRINTS/  TITLE(30) .TIMLBL 
CHARACTERS  TITLE 
CHARACTER'S  TIMLBL 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM 

LOGICAL  PTHDR 

COMMON  /JJJ/  PTHDR 

COMMON  /RAYNIT/  KGMH,NOCRVS,NUCRVS, IUPOWN, TO,PHIO,XO, Y0.20, 

*  P10 , P20 , P30 , OMEGA , DELTAO , PI FO , P2F0 , P3F0.0MEGAF , 

+  XT0,YT0,ZT0,P1T0,P2T0,P3T0,QMEGAT,XS0,YS0,ZS0, 

♦  P3SO , R  HOO , PCONST , NAGE  S , AGES ( 20 ) 

INTEGER  KGMH , NOCRVS , NUCR VS , I UPDUN 

REAL  P«'S),PYF(2),p(CT<2) 

EQUIVALENCE  (PK(1),P10),(P<F(1),P1FO),(PKT(1),P1TO) 

C 

C-  RETURN  TO  AVOID  OUTPUT 
C 

IF  ( T YPE. NE. 'CAUSTIC  ')  RETURN 
NCLAS*3 

IF  (KGMH.EQ. 1 )  GO  TO  10 
NCLAS=2« ( N0CRVS*3*<3 - KGMH*2* ( 2 ■ IUPDUN ) )  )+3 
10  RECPHI =AMOG ( AMOO ( PH  1 0 , 360 . )*450 . , 360 . ) -  90 . 

RSIGM=(SIG) 

DO  20  <=1,3 
RK4(K)sRK(K) 

RF4(K)*RF(K) 

RT4(K)*RT(K) 


20  CONTINUE 


IF  (PTHOR)  THEN 
WRITE(7,5)  TITLE 

5  FORMAT < 1 1 * ,30A4) 

WR1TE(7,6)  TIMLSL, TIMLBL 

6  FORMAT! ‘0  POINT' , Til, '#HIGH  #LOW' ,T22, 'RAY' ,T34, 'TIME' ,T44, 'PHI ‘ , 
♦T54, 'TIME'. T66,'X\T76,'Y'.T86.'Z\T93, 'RAY  NORMAL' .T109, 'AREA'/ 
♦T3, 'TYPE' ,T21, 'CLASS' ,T32, 1 (INITIAL) ' ,T42, '< INITIAL) * ,T93, 'AZIMUTH 
+ELEV ' /T33,A8, T53 , A8 , T65 , * MET ' , T75 , ' MET • , T8S , ' MET ' , T93 , ' DEG • , T 1 00 , 

♦  'DEG' ,T106, 'MET**2/SEC‘ ) 

END  IF 

PTHOR  »  .FALSE. 

TPRN»T!MCVR((T0),2) 

SIGPRN*T1MCVR((RSIGM),2) 

CALL  £AMENU(EL£V,AZIM,PMAG,PK( 1 ),PK(2) , PZ) 

220  F0RMAT(1X,A8,2I5,T22,A8,T31 ,2F10.5,  T48,  F10. 1 .2F10.0,  F10. 1 , 

♦F7.0, F7.1 ,G12.4) 

100  RETURN 


c 

c 

-  ft******************************************************************** 

C  *  SIGNATURE  CALCULATIONS  -  ROSPCL, SI GNUR, FREAO .AGING, HILBRT  * 

C  *  $1GPRT,CPVAL,S0RTEM  * 

C  *  (DREAO, FFA2F, FFA21 )  * 

c  . . * . . 

C 

C  AFTER  ALL  RAYS  HAVE  SEEN  TRACED,  IT  IS  THE  TASK  OF  THE  SIGNATURE  AGIN 


C  ROUTINES  TO  PERFORM  THE  FINAL  CALCULATIONS  AND  DETERMINE  THE  ACTUAL 
C  OVERPRESSURES  TO  3E  EXPECTED. 

C 

SUBROUTINE  ROSPCL 
C 

C  ROSPCL  IS  ACTUALLY  BETWEEN  THE  RAY  TRACING  ROUTINES  AND  THE  SIGNATURE 
C  CALULATIONS  PER  SE.  IT  LISTS  ALL  THE  SPECIAL  POINTS  RECOROED  BY  RCSPC 
C 

CHARACTER'S  PTTYPE.RYCLAS 
REAL  SIGPRN ,TPRN , TIMCVR 

REAL  RK(3),XF!3),XT(3),PK(3) 

INTEGER  NHIGH.NLOU 

COMMON  /PRINTS/  TITLE<30),TIMLBL 
CHARACTER**  TITLE 
CHARACTER'S  TIMLBL 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRTIM  . 

C  WRITE! 7, 5)  TITLE 

C  5  FORMAT (M',30A4> 

C  WRITE(7,6)  TIMLBL, TIMLBL 

C  6  FORMAT C 1 0  POINT1, Til, '#HIGH  #LOW' , T22, 1  RAY 1 ,T34, 1  TIME 1 ,T44, •PHI 1 , 

C  ♦  T54, "TIME1, T66, 'X',T76, ’Y',T86,'Z’,T93, 'RAY  NORMAL  1 ,TT09, 'AREA V 
C  »T3, 'TYPE ' ,T21 , 'CLASS' ,T32, '( INITIAL) ’ ,T42, 1 (INITIAL) ' , T93, 'AZIMUTH 
C  +  ELEV'/T33,A8, T53.A8, T65, 'MET 1 , T75, 'MET' ,T8S, 'MET' ,T93, 'DEG'.TIOO, 
C  ♦  '  DEG ' ,  T1 06 , '  MET"2/SEC ' ) 

10  REAO( 9 , 200 , ENO* 1 00 )  PTTYPE.RYCLAS 
200  FORMAT (2A8) 

READ! 9,*, END* 100)  NHIGH,NLOW,TIMO, PHIO, SIGMA, RK,XF, 

*  XT, AREA, PK 

TPRN*TIMCVR(!TIMO) ,2) 

SIGPRN*TIHCVR( (SIGMA) ,2) 

CALL  EAMENU(ELEV,AZIM,PMAG,PK(1 ),PK(2) ,PK(3) ) 

C  WRITE(7,20)  PTTYPE , NH IGH , NLOW, RYCLAS, TPRN , PH  1 0 , SI GPRN , RK, AZIM, 

C  *  ELEV.AREA 

C  20  FORMAT (1X,A8,2I5,T22,A8,T311F10.1,F8.2,T50,F10.1,2F10.0,F10.1, 

C  *F7.0,F7. 1.G12.4) 

GO  TO  10 
100  RETURN 
END 


:ss33s:ss:sss»s22»zsx 


c 

CS3S8S3S3S83S3S8SSS3SSS8SSSa8S133S38aSSSSMSSS8SSS 
[:::sssss3xss3ss3s3x:s23s3=:s3:s:s:s3s3s3ssssss:xs::ss:s:3:s5s:s3»3:ss: 

c 

SUBROUTINE  SIGNUR(MAXOP > 

C 

C  SIGNUR  HAS  OVERALL  CONTROL  OF  THE  AGING  AND  PRINTOUT  PROCESS.  FOR  EAC 
C  RAY  TERMINUS  RECORDED  BY  RECORO,  IT  READS,  INTERPRETS  AND  PRINTS  OUT 
C  THE  INFORMATION  ON  RAY  TYPE,  MACH  NUMBER  OF  AIRCRAFT,  INITIATION  TIME 
C  ANO  PHI  ANGLE,  LOCATION,  ELEVATION  AND  AZIMUTH  OF  THE  RAY  NORMALS,  AN 
C  THE  CONVERSION  FACTORS  FROM  F-FUNCTION  NORMALIZED  COORDINATES  NORMAL  I 
C  COORDINATES  TO  TIME  (TFACT)  ANO  PRESSURE  (PFACT).  IT  COMBINES  THE 
C  F- FUNCTIONS  ACCORDING  TO  THIS  INFORMATION  AND  CONTROLS  THE  EVOLUTION 
C  THE  SIGNATURE. 

C 

C  PARAMETERS  :  NAME  TYPE  DISCROPTION 

C 

C  INPUT  :  NONE 

C 

C  OUTPUT  :  MAXOP  :  R  MAXIMUM  OVERPRESURE 

C 

REAL  MAX  OP 

COMMON  /FFTAB/  KRCAC , NSPDS , SPEEDS!  11), LXSPO <  1 0) , XT ABL , 

♦  NTAU,TAU<200) , FAC(ZOO) , FLC(200) 

COMMON  /CFFTA8/  ACIONT 

CHARACTER'S  ACIONT 

COMMON  /BASEAG/  NTERMS,XILEAD(2),XI (500), XI TAIL (502), 

♦  VLEA0<2) ,V(500) , VTAILC502) 

DIMENSION  XI I (1004), VI (1004) 

EQUIVALENCE  (XI I ( 1 ),X!LEAD( 1 >>, (VI ( 1 > , VLEADC 1 )) 

COMMON  /PRINTS/  TITLE(30) , TIMLBL 
CHARACTER*4  TITLE 
CHARACTER'8  TIMLBL 

COMMON  /PRINTC/  XTPSIG, CVRT IM 
LOGICAL  CVRTIM 

REAL  SIGD,TD0 
REAL  TIMCVR 

COMMON  /SIGPAR/  KGMH ,  NRCURV,  I UPCWN ,  XilACH ,  VL I  FT ,  TO , 

+  PHI0,S1GMA,XK(3) ,0MEGA,PK(3) , XKS(3) ,XKT(3) , 

+  XKF(3),PFACT,NAGES,AGES(20) 

COMMON  /SIGPAC/  !DENT,RAYNAM 
character's  IDENT.RAYNAM 

INTEGER  XGMH, NRCURV, IUPDWN 

COMMON  /RAYOUT/  SSI GMA, SPH 10, SXK(3) , OPG , CSEL 


IF  (KTPSIG.LE.O)  RETURN 
REWIND  9 

READ(9, 1 (A8) 1 )  IDENT 
C  WRITEL7, 15)  TITLE 

C  IF  (KTPSIG.SE. 2)  CALL  FREAO 

IF  (KTPSIG.GT. 1 )  GO  TO  10 
C  WRITE(7, 16)  IDENT 

C  WR1TE(7,20)  TIMLBL.TIMLBL 

10  CONTINUE 

READ(9,99,£N0*500)  RAY NAN 
99  FORMAT (A8) 

READ(9, * , £ND*500)  KGNH , NRCURV , I UPOWN , XMACH , VL 1  FT , TO , PH 1 0 , 

♦  SI GNA , XK , OMEGA , PK , XKS , XKT , XKF , PF ACT , NAGES , 

♦  (AG£S(K),K*1, NAGES) 

CALL  EAMENU(ELEV,AZ1M,PMAG,PK(1),PK(2),PK(3)) 

IF  (KTPSIG-2)  25,17,11 

11  CONTINUE 

C  WRITE(7, 15)  TITLE 

15  FORMAT < • 1 • , 30A4) 

C  URITE(7, 16)  IDENT 

16  FORMATCOA/C  IDENT*', A8) 

17  CONTINUE 

C  WRITE(7,20)  TIMLBL.TIMLBL 

C  20  FORMAT ( 1  RAY  TYPE  MACH#1 , T20, 'TINIT' , T28, 'PHI O' ,T37, 'TIME' , T50, 'X' 
C  ♦  ,T60, 'Y',T67, ‘Z',T72, ' RAY  NORMAL ' ,T84, 'TFACT ' ,T91 , 'PFACT ' ,T104, 

C  ♦  ' VLi FT ' /T20, A8, T28, 'OEG. • ,T36,A8,T49, 'MET' ,T59, 'MET' ,T66, 'MET' , 

C  ♦  T71, 'AZIMUTH  ELEV' ,T83, 'MS/MET ' , T90, • PA/MET** .5 ' , T 104 , 'MET**2 ' ) 

25  TFACT*1000. /OMEGA 
TDO*TIMCVR( (TO) ,2) 

SIGD*TIMCVR( (SI GMA) ,2) 

C  WRITE(7, 100)  RAYNAM, XMACH, TOO, PHIO,SI GO ,XK,AZIM, ELEV, TFACT, 

C  ♦  PFACT, VLIFT,(AGES(K),K*1, NAGES) 

C  100  FORMAT( 'O' ,A8, IX, F5.3, F10. 1 , F7.2, F10. 1 ,2F10.0, F6. 1 , F7.0, F7. 1 , F6.3, 
C  ♦  2G11 .4, (/T19, ' AGES(M**.5)*' , 9F9.2)) 

C  IF  (KTPSIG.EQ. 1 )  GO  TO  10 

C  CALL  NEWTAB 

DO  200  K*1 ,NTAU 
XI (K)*TAU(K) 

V(K)»FAC(K)*VLIFT*FLC(K) 

200  CONTINUE 
NTERMS=NTAU 

CALL  AGING(AGES(1)) 

IF  (NAGES. LE.1)  GO  TO  215 


00  210  K*2, NAGES 


CALL  H1LSRT 
CALL  AGtNG(AGESOO) 
210  CONTINUE 

215  CALL  SIGPRT (MAXOP) 

500  RETURN 
END 


WARN IMG 


C .  FREAD  IS  NO  LONGER  USED  TO  READ  IN  THE  F- FUNCTIONS 

Z .  F- FUNCTIONS  ARE  GENERATED  USING  FFUNC.  FREAD  IS 

C .  RETAINED  INOROER  TO  KEEP  THE  ABILITY  TO  INPUT 

C .  T.R.A.P.S  TYPE  F-FUNCTIONS. 

C . 

C . 

c 


SUBROUT 'ME  FREAD 
C 

C  FREAD  DETERMINES  WHETHER  THE  NECESSARY  F- FUNCTION  TABLES  ARE  IN  MAIN 
C  MEMORY,  AND  IF  NOT,  READS  THEM  INTO  MAIN  MEMORY. 

C 

C  HAS  ENTRY  POINT  AT  NEWTAB 

COMMON  /SIGPAR/  KGMH.NRCURV, IUPOWN,XMACH,VLIFT,TO, 

♦  PHIO, SIGMA, XK<3>, OMEGA, PK(3),XKS(3),XKT(3), 

♦  XKF(3) ,PFACT - NAGES , AGES(20) 

COMMON  /SIGPAC/  IOENT.RAYNAM 
CHARACTER'S  IOENT.RAYNAM 

INTEGER  KGMH.NRCURV, 1UPOWN 

COMMON  /FFTAB/  KRCAC, NSPDS , SPEEDS! 11), LOCSPDC 10) , KTABL , 

♦  NTAU,TAU<200) , FACC200) , FLCC200) 

COMMON  /CFFTAB/  ACIDNT 

CHARACTER'S  ACIDNT 
CHARACTER'8  ACID 
CHARACTER*15  F0RM<4) 

COMMON  /FERMSG/MESGI 26 ) 

LOGICAL  OPENED 
C 

C  VARIABLE  FORMAT  SPECIFIER 

C 

DATA  FORM/ 1 (T28, F5 .2, F5. 0) 1 , 1 (T38, F5 .2, F5.0) 1 , 1 (T48, F5.2, F5.0) 1 , 

+  1 (T58, F5.2, F5.0) •/ 

DATA  OPENED/. FALSE./ 

IF  (.NOT. OPENED)  THEN 

OPEN(90iFILE*‘FFUNC.0IR' ,STATUS='OLD' ,ACCESS='DIRECT' , 

♦  FORM=‘FORMATTED',RECL=80> 

OPENED  =  .TRUE. 

END  I  F 

C 

C  CALL  LJUST(8,1,IDENT, ACIDNT) 


CALL  ACCVRT ( I DENT , AC I DNT ) 


KRCAC=1 

C  10  CALL  OREAD (90, KRCAC, BUFFER, *900} 

10  CONTINUE 
C 

C  READ  FOR  FORTRAN  V 
C 

READ (90,991, REC=KRCAC , ERR*900 )  AC  ID ,  KI  NCR , NSPOS 
991  FORMAT (A8.T18, IS,T26, 12) 

C  IF  (ACIDNT.EQ.8UFFERC 1 } )  GO  TO  20 

IF  (ACIDNT.EO.ACID)  GOTO  20 

C  CALL  FFA2N(8UFF£R ,18,5,1 ,0UMMY , Q. ,KERR ) 

READ (90 , 995 , REC=KRCAC , ERR=900 )  DUMMY 

995  FORMAT (T18.F5.0) 

KINCR=0UMMY*.5 
IF  (KINCR.EQ.O)  GO  TO  950 

c$mssss$sssssssssssss»ssss$s$ss$$ss$sss$ssmss 
c  krcac*krqaa+kincr 

csssss$ssss$ss$ss»ssssssss$ss$sssss$ss$smssss$s 

KRCAC  *  KRCAC  ♦  K1NCR 
GO  TO  10 

C  20  CALL  FFA2N(BUFFER, 26, 2,1, DUMMY, 1., KERR) 

20  CONTINUE 

READ (90 , 996 , REC=KRCAC , ERR=900 )  DUMMY 

996  FORMAT (T26, F2.0) 

NSPDS=0UMMY+.5 
NCARDS=(NSP0S+3)/4 
DO  40  I =1 , NCARDS 
<1=1 

K2=MINO(4,N$POS-4*( I • 1 ) ) 

DO  30  K=K1 ,K2 
KK=K+4*< I  •  1 ) 

C  CALL  FFA2N(3UFFER,18+10*K,5,1,SPEEDS(KK),0.,KERR) 

C  CALL  FFA2N(BUFFER, 23+10*K, 5,1, DUMMY, 0., KERR) 

c 

C  READ  WITH  A  DIFFERENT  FORMAT  TO  GET  EACH  MACH  NUMBER  AND 
C  REUTIVE  ADDRESS  PAIR  IN  ORDER 
C 

READ (90, FORM(K) , R£C=KRCAC+ I  - 1 , ERR =900)  SPEEDS(KK) , DUMMY 

LOCSPO(KK)=OUMMY*.5 

IOCSPD(KK}=LOCSPO(KK)*KRCAC 


30  CONTINUE 


C  CALL  0READ(90,KRCAC+I, SUFFER, *900) 


40  CONTINUE 

WRITE{7(50)  IDENT,(SPEEDS(K),K=1,NSPDS) 

50  FORMAT ( 1  OF- FUNCTION  TABLES  FOR  1 , A8 , '  AIRCRAFT.1/'  TABLES  FOR  MAC 
+H  NUMBERS' ,20F5. 2) 

SPEEDSCNSPC 5+1 )»$PEEDS(NSPDS) 

OO  60  M*1,NSP0S 

$PEEDS(NSPDS-M+2)». 5* ( SPEEDS (NSP0S-M+2)*SPEEDS(NSP0S-M+1 )) 

60  CONTINUE 
SPE£DS(1 )*1 . 

LTA8L*1 
GO  TO  150 

C  ENTRY  POINT 

ENTRY  NEUTAB 

IF  (NSPOS.EQ. 1 )  RETURN 
DO  100  K=1 , NSPDS 

IF  (AMIN1(XMACH-SPEEDS(K) , SPEEDS(K+1 ) -XMACH) .GE.O. )  GO  TO  120 
100  CONTINUE 

IF  (XMACH .GT.SPEEDS(NSP0S+1 ) )  WRITE(7,110)  XMACH,SPEEDS(NSPDS+1 ) 
110  FORMAT ( 1  MACH  NUMBER  \F5.2,1  IS  GREATER  THAN  MAXIMUM  IN  TABLES  1 
♦, FS.2, 1 .  SUGGEST  EXTENDING  TA8LES. 1 ) 

K=NSPOS 
120  LTABL*K 

IF  (LTABL.EO.KTA8L)  RETURN 
150  KTA8L=LTA8L 

MREC*LOCSPD  ( KTABL ) 

C  CALL  DREAD ( 90 ,MREC, BUFFER, *900) 

C  CALL  FFA2N(BUFFER,16,6,1,XLAC,0.,XERR) 

C  CALL  FFA2N(BUFFER, 22, 7,1, STEP, 0., KERR) 

C  CALL  FFA2NC8UFFER, 13, 3,1, DUMMY, 0..KERR) 

READ (90 , 992 , REC=MREC , ERR=900 >  DUMMY , XLAC , STEP 

992  FORMAT (T13,F3.0,T16, F6.2,T22, F7.2) 

NT  AU*OUMMY  + . 5 
XLR*SQRT (XLAC) 

CONST=1./(XLR*XLAC) 

OO  200  K*1 ,NTAU 

C  CALL  FFA2N(BUFFER,48,3, 1 , EXP 10,0. ,KERR) 

C  CALL  FFA2N(BUFFER, 35,12, 1,FAC(K),0., KERR) 

C  FAC(K)*FAC(K)+XLR»(10.*»EXP10) 

READ(90,993,REC=MREC+K-1,ERR=900)  FAC(K), FLC(K) 

993  FORMAT ( T35 ,£16.9, T54 , E16. 9) 


FAC(K)=FAC(K)*XLR 


C  CAU  FFA2N(8UFFER,67,3, 1  , EXP10,0.  ,KERR) 

C  CALL  FFA2N( BUFFER, 54, 12,1 , FLCCK) ,0. ,KERR) 

C  FLC(K)*FLC(IO*CONST*(  10.  **£XP10) 

FLC(K)=FLCOO*CONST 

TAU(IO=(K- 1  )*ST£P*XLAC 

C  CALL  DRE AD ( 90 , MREC+K , 8UF  FER , *900 ) 

200  CONTINUE 
RETURN 

900  UR1TE<7,910)  MESO 

910  FORMAT ( '  OA/IO  ERROR  ON  UNIT  90. '/IX, 18, I6,20A4,4I9) 

STOP  900 

950  UR1TE(7,960)  IOENT 

960  FORMAT ( 1  AIRCRAFT  ID  ',A8,'  NOT  FOUND.  PROGRAM  TERMINATED.') 
STOP  960 


c 

SUBROUTINE  AGING(AGE) 

C 

C  AGING  SHIFTS  THE  ABSCISSA  VALUES  (PHASE)  OF  THE  F- FUNCTIONS  ACCOROING 
C  TO  THE  AGE  VALUE,  DETERMINES  THE  TOTAL  AREA  OF  THE  RESULTING  FIGURE, 

C  ANO  FITS  JUMP  OICONTINUITIES  AS  APPROPIATE.  REPUCES  THE  INPUT  F-FUNC 
C  WITH  THE  RESULT. 

C 

COMMON  /BASEAG/  NTERMS ,XILEAD(2) ,XI (500) ,XITAI L(502) , 

♦  VL£AD(2), V(500) , VTAILC502) 

LOGICAL  JUMP 

REAL  SA , SB , SC , SO , SE 1 , SE2 

DIMENSION  XI1(1004),VI(1004) 

EQUIVALENCE  (XI I ( 1 ) ,XIL£AD< 1 )), (VI (1 ) , VLEAD( 1 >) 

C 

DO  2  K=1 ,2 

XI 1 (K)*XI ( 1 ) 

XI I  (NTERMS+K+2)*XI  (NTERMS) 

VI(K)*0. 

VI(NTERMS+K*2)*0. 

2  CONTINUE 
LTERMS=2 
K=2 

XIB=XI 1(2) 

VB=0. 

S8=0.0 

1*2 

VO=0. 

SD=0.Q 
X I D=X 1 1 (2) 

JUMP*. FALSE. 

5  K*K+1 

IF  (K.GT.NTERMS+4)  GO  TO  200 

XI A*XIB 

VA=V8 

SA=SB 

VB=VI«) 

X1B=XII(K)-AGE*VB 

S8=SA+(.50*(XIB-XIA))»(VS+VA) 

XI I  ( 1 )*AMIN1 (XI I (1 ) ,XIB) 

XI I  (NTERMS+4)=AMAX1 (XI I (NTERMS+4) ,XI B) 

IF  (JUMP)  GO  TO  15 

IF  (XI3.LT. XIA)  GO  TO  10 

LTERMS*LTERMS+1 

XI I  (LTERMS)=XIB 

VI(LTERMS)=VB 

GO  TO  5 


10  JUMP* . TRUE . 

GO  TO  5 

15  IF  (XIB.LE.XIA)  GO  TO  5 
17  XIC*XII(L-1) 

VOVKL-1) 

SC*SD • < .50*(VC+VD ))*(X1D-XIC) 

IF  (X1C.LE.XIA)  GO  TO  21 

L*l-1 

VO*VC 

XI0*XIC 

so*sc 

GO  TO  17 

20  L*L+1 
XIC=XID 
VC=VD 
SC*S0 

XID=X1 I (L) 

VO=VI <L) 

S0*SC+<.50*<VC+V0))*(X!D-XIC) 

21  IF  (XIB.LE.X1C)  GO  TO  5 

IF  (XID.LE.X1C)  GO  TO  20 

IF  (XIA.GT.XIO)  GO  TO  20 

XI£=AMIN1 (XIB,XID) 

VE1*<VB*(XIE-XIA)*VA*(XIB-X1E))/(XIB-XIA) 

VE2*(VD*(XIE-XIC)*VC*(XI0-XI£))/(XI0-XIC> 

SE1*SA*(.50*(VE1+VA))*(X1E-X!A> 

SE2=SC+< .50*(VE2+VC))*<XIE-XIC) 

C*SE1 -SE2 
IF  <C)  25,40,30 
25  IF  (XID-XI8)  20,5,5 
30  A=(VB-VA)/(XIB-XIA)-(VD-VC)/(XID-XIC) 
B=VE1-VE2 

XIE=XIE-2.*C/(B+SORT(B**2-2.«A*C)) 
VE1*(VB*(XIE-XI A)+VA*(XIB-XIE))/(XIB-XIA) 
VE2*(VD*(XIE-XIC)+VC*(XID-XIE))/<XID-XIC) 
SE2=$C+(  .50*(VC-*-VE2))*(XIE-XIC> 

40  S8*SE2+(.50*(VE1+VB))*<XIB-XIE) 

XI I (L)*XIE 
/I(L)*VE2 
XI I(L+1 )*XIE 
VKl+1 )*VE1 
XI I (l*2)=XIB 
VI (l+2)=V8 
1=1+2 
S0*S8 
XID*X!B 
V0*V8 
ITERMS=L 
JUMP*. FALSE. 

GO  TO  5 
200  LL=1 

DO  220  1=3 , LTERMS 

IF  (XII(LL).EO.Xiia))  GO  TO  220 
IF  (XIIUL).LT.XIIU-I))  OO  TO  210 


210 


220 


IF  (VI (LL) .EQ.VI (L- 1 ) )  GO  TO  220 

XIICll>1)*XIta-1) 

VI(LL*1)«Via-1) 

U»LL*1 

CONTINUE 

XnaL*1)*XII(LTERNS) 

VKLL+1  )*VI(LTERMS) 

NTERHS*U-3 

RETURN 

END 


Csasssssssssssssssssssssssssssssssssssssssssssssssssssrzssszssss:::::::* 

c 

SUBROUTINE  HILBRT 
C 

C  HILBERT  HAS  OVERALL  RESPONSIBILITY  FOR  CALCULATING  THE  HILBERT  TRANSF 
C  REPLACES  THE  INPUT  F-FUNCTION,  AS  MOOIFIED  BY  AGING  ANO  POSSIBLY 
C  CONTAINING  SHOCKS,  BY  ITS  HILBERT  TRANSFORM.  COMPUTES  THE  TRANSFORM  A 
C  A  SELECTION  OF  POINTS  DETERMINED  BY  THE  OVERALL  STRUCTURE  OF  THE 
C  FUNCTION.  THIS  INCLUDES  A  SET  OF  POINTS  EXPONENTIALLY  CONVERGING  TO 
C  EACH  SHOCK  (TERMINATING  WITHIN  A  DISTANCE  OF  THE  SHOCK  EQUAL  TO  6*10E 
C  TIMES  THE  OVERALL  SCALE  OF  THE  INPUT  F-FUNCTION).  IT  ALSO  INCLUDES  A 
C  SET  OF  POINTS  WHICH  ARE  CENTERED  ON  THE  MEAN  ABSCISSA  VALUE  OF  THE 
C  INPUT  F- FUNCTION  AND  WHICH  ARE  SPACED  AT  INCREASING  INCREMENTS  TO  COV 
C  AN  INTERVAL  SEVERAL  TIMES  THE  ABSCISSA  SCALE  OF  THE  INPUT  F-FUNCTION. 
C 

COMMON  /BASEAG/  NTERMS ,XI LEAD(2) ,X! (500) ,XITAIL(502) , 

+  VLEADC2) ,V(500),VTAIL(502) 

DIMENSION  XII ( 1004) , VI (1004) 

EQUIVALENCE  (XI 1  (1 )  ,X1LEAD(1 )),  (VI  (1 ) ,  VLEADO  )) 

COMMON  /XI SAVE/  NSTRMS,XIS(502) ,VS(S02) 

C 

WEIGHTS. 

XIMEAN=0. 

XIVAR»0. 

XIS(1 )»XI I (2) 

VS(1)=>0. 

NSTRMS=NTERMS+2 
OO  10  K=2,NSTRMS 
XIS(K)=XI (K- 1 ) 

VS(K)=V(K- 1 ) 

AWAIT1»VS(K- 1 )**2 
AWAIT2-VS(K- 1 )*VS(K) 

AUAIT3=VS(K)**2 
DELXI=XIS(K)-XIS(K- 1 ) 

WAV«OELX I *( AWA I T1+AWA I T2+AWA IT3)/3. 

WAVX=XIS(K-1)*WAV*((AWAIT1*2.*AWAIT2+3.*AWAIT3)*DELXI**2)/12. 
WAVX2*(WAV*XIS(K- 1 )+2.*WAVX)*XI S(K- 1 )+(AWAIT1+3.* 

&  AWAIT2+6.*AWAlT3)*DELXI*DELXl*DELXI/30. 

WE  I GHT=WE I GHT+WAV 
X I MEAN=X I MEAN+WAVX 
X I VAR*X I VAR*WAVX2 
10  CONTINUE 

X I MEAN=X I MEAN/WE  I GHT 
XI VAR=XI VAR/WEIGHT -XIMEAN**2 
XI LNG=SQRT(X I  VAR ) 

LTRMHF=40 

LTERMS=LTRMHF*2+1 

NTERMS=0 

00  100  L=1 , LTERMS 


XINEW*XILNG*(LTERMS*(L'LTRHHF)/{L*(LTERMS+1 . -L)))+XIMEAN 

CALL  CPVAL  <X I  NEW, W ,*100) 

NTERMS*N  TERMS* 1 
V(NTERMS)*W 
X I ( NTERMS )*X 1 NEU 
100  CONTINUE 

XI (NTERMS* 1 )*2.*(XI( 1 1-XIMEAN  5+XIMEAN 

X I <  NTERMS+2 )*2 . * (X I ( NTERMS ) - X 1 MEAN  >+X IMEAN 

V(NTERMS*1)«0. 

V( NTERMS+2 )*0. 

NTERMS-NTERMS+2 
00  200  X*2,NSTRMS 

IF  (XIS(X).GT.XIS(X-D)  GO  TO  200 
IF  (VS(K).EQ.VS(K-I))  GO  TO  200 
OELXI»XILNG 
DO  190  M*1 , 10 
DELXI*0ELXI*.3 

CALL  CPVALCX1S(X)-0ELX1,W,*180> 

NTERMS»NTERMS+1 

XI(NTERMS)*XIS«)-OELXI 

V(NTERMS)*W 

180  CALL  CPVAL(XIS<K)*0ELXI,W,*190> 

NTERMS*NTERMS+1 
XI(NTERMS)=>X1S(K)+0ELXI 
V(NTERMS)=W 
190  CONTINUE 
200  CONTINUE 

CALL  SORTEM 


RETURN 

END 


saasaassMaxssaasassssaaisssssrsstsssaaaasasssassas 


SUBROUTINE  SIGPRT(MAXOP) 


SIGPRT  PRINTS  OUT  THE  FINAL  SIGNATURE,  AS  DIRECTED  ON  THE  CONTROL 
FILE  CARDS. 


PARAMETERS 


INPUT  : 


TYPE  DISCROPTION 


OUTPUT  :  MAX OP  :  R  MAXIMUM  OVERPRESURE 

REAL  MAXOP 

COMMON  /PRINTS/  TITLE(30) ,TIMLBL 
CHARACTER**  TITLE 
CHARACTER'8  TIMLBL 

COMMON  /PR INTO/  KTPSIG,CVRTIM 
LOGICAL  CVRTIM 

COMMON  /BASEAG/  NTERMS,XILEAD(2) ,XI (500) ,XITAI L(502) , 

♦  VLEAD<2) , V(500),VTA1L(502) 

DIMENSION  XII C 1004), VI <1004) 

EQUIVALENCE  (XI I ( 1 ) ,XILEA0< 1 >) , (VI (1 ) , VLEADC 1 ) ) 

COMMON  /SIGPAR/  KGMH , NRCURV, IUP0UN, XMACH , VLI FT , TO , 

♦  PH10,SIGMA,XK(3>  OMEGA,PK(3),XKS(3>,XICT(3), 

♦  XKF(3),PFACT,NAGES,AGES(20) 

COMMON  /SIGPAC/  IDENT.RAYNAM 
CHARACTER'S  IOENT.RAYNAM 
INTEGER  KGMH , NRCURV I UPOWN 

COMMON  /RAYOUT/  SSIGMA, SPH 10, SXK(3) ,0PG, CSEL 

INTEGER  NSIG 

REAL  CCSEL,XXT(50*),PPT(504) 

DATA  DGPRAD/57. 295780/ 

IF  (KTPSIG.LE.1)  RETURN 
TFACT= 1000. /OMEGA 
PMAX=0. 

PMIN=0. 

DO  220  K=1 , NTERMS 
V(K)=VOO*PFACT 
PM AX = AM AX  1 (PM AX , V(K) ) 

PMIN=AMIN1(PMIN,V(K)) 

220  CONTINUE 


P$IG*.05*(PMAX-PMIN) 

KMAX*1 
KX1N*NTERMS 
00  225  K«1,NT£RMS 

IP  (ABS(V(K)).LT.PSIG)  GO  TO  225 
KMIN*M!NO(KMIN,K) 

KMAX*MAX0  OCMAX ,  K+2  ) 

22S  CONTINUE 

0!R*OGPRAD*ATAN2<PK(1),PK<2))+180. 

PN«SQRT (PK(1 )**2*PK(2)**2) 

NSHOCK*0 
NN-NTERMS+1 
00  250  K*1 , NN 

IP  (XII (K+1 ).LT.XI I (K+2))  GO  TO  250 
IF  (VIOC+1).G£.Vl(K+2))  GO  TO  250 
NSHOCK*NSHOCK+  1 
AXI»XI I (K+1 ) 

TPR=AXI*TPACT 

XPR=AXI/PN 

PONE=VI(K*1) 

PTWO=VI(K+2) 

KMIN=MINO(KMIN,IO 
KMAX*MAX0(KMAX,K*1 ) 

250  CONTINUE 

c 

C-  CALCULATE  ABSOLUTE  MAXINUN  OVERPRESURE 
C 

MAXOP  =>  ANAXl  ( ABSCPMI N)  ,  ABS(PMAX)  ) 

OPG  *  MAXOP 
SSIGMA  *  SIGMA 
SPHIO  »  PHIO 
OO  823  1*1,3 
SXK(I)  *  XK Cl) 

823  CONTINUE 
IIJ  *  0 

OO  867  III  *  KM IN, KM AX 
IIJ  *  IIJ  ♦  1 

XXT(IIJ)  *  (XII(III)  -  XI I (KMIN))*TFACT 
PPT(IIJ)  =  Vt(III) 

867  CONTINUE 

NSIG  *  KMAX  -  KMIN  ♦  1 

CALL  CALSEL(PPT,XXT,NSIG,CCSEL) 

CSEL  *  CCSEL 

CALL  PRTSNG(XXT,PPT, NSIG, OMEGA) 


500  RETURN 


c 

Oss*3****M**a«M*a*sasas*a*ssas3s*aassajisssss=sssss=assss3ssss5S2=3sss: 

C==ss3aissaass3sssaaa3asa53assssss3sss35saissss=sss=ss5sss3=5sssa=sssss: 

c 

SUBROUTINE  CPVAUX1ARG, V,*) 

C 

C  CPVAL  COMPUTES  THE  VALUE  OF  THE  INTEGRAL  DEFINING  THE  HILBERT 
C  TRANSFORM,  AS  A  CAUCHY  PRINCIPAL  VALUE,  AT  EACH  POINT  DIRECTED 
C  BY  HILBERT. 

C 

COMMON  /XI SAVE/  NSTRMS ,XIS<502) , VSC502) 

REAL  SUM,ALPHA,RATIO,VSA, VSB.DI FI ,DI F2,DI F3,PI ,DI FA.DI FB 
DATA  Pl/3. 141592653589790+0/ 

SUM-0.0 

DO  50  K-2, NSTRMS 

OIFA=(XISOC))-XIARG 
DI FB*(XIS(K- 1 ) ) -XI ARG 
DIF2-0IFA 
DIF1-0IFB 

IF  (ABSCDI F2) .GE.ABS(D I  FI ) )  GO  TO  5 

DIF3-OIF2 

DIF2-0IF1 

DIF1-0IF3 

5  IF  (D1F1.NE.0.)  GO  TO  15 

IF  {DI F2.NE.0. )  GO  TO  7 
IF  (VS(K).EO.VS(K-D)  GO  TO  50 
RETURN  1 

7  ALPHA-- AL0G(ABS(D1 F2) )/D I F2 
GO  TO  30 

15  RAT IO-<D I FZ-OI FI )/0I F2 

IF  (ABS(RATIO) .LT . .50-4)  GO  TO  20 
ALPHA=ALOG<ASS(DIF1/DIF2))/<DIF1-DIFZ) 

GO  TO  30 

20  ALPHA-( { ( . 250+RAT 1 0+ 1 . 0/3 . 0 )*R AT  1 0+ . 50 )*RAT 1 0+ 

&  1.01/DIF2 

30  VSA-VS(K) 

VS8-VS0C-1) 

SUM-SUM* ( • VSA*D I FB+VS8*D I F A ) ‘ALPHA 
50  COMTINUE 
V-SUM/PI 
RETURN 
END 


C  ASCENDING  ORDER  OF  ABSCISSA  VALUES,  AS  REQUIRED  S Y  AGING. 


C 


COMMON  /BASEAG/  NTERMS ,XIl£AD(2) ,XI ( 1000) ,XITAIL(2) , 
♦  VIEAD(2),V(100C) ,VTAIl(2) 


LSTRT2-1 

LSIZE*1 

10  LSTRT1*LSTRT2 

LSTOP1*LSTRT1+NTERMS* 1 
LSTRT2*NTERMS+2 • LSTRT2 
KC*LSTRT2 
KSTOPB=LSTRT1 • 1 
20  KSTRTA»KSTOPB*1 

KSTOPA*MINO(KSTRTA*LS1 ZE* 1 , LSTOP1 ) 
KSTRT8*KST0PA*1 

KSTOP8=MINO(KSTRTB+LSIZE- 1 ,  LSTOP1 ) 

IF  (KSTRTA.GT.KSTOPA)  GO  TO  90 

30  IF  (KSTRT8.GT.KSTOPB)  GO  TO  70 

IF  (KSTRTA.GT.KSTOPA)  GO  TO  50 

IF  (XI (KSTRTA)’XI (KSTRTB))  36,33,40 
33  IF  (V(KSTRTA).GT.V(KSTRTB))  GO-  TO  40 
36  XI (KC)*XI (KSTRTA) 

V(KC)*V(KSTRTA) 

KC=KC+1 

KSTRTA=KSTRTA*1 
GO  TO  30 

40  XI (KC)=XI (KSTRTB) 

V(KC)*V( KSTRTB) 

KC=KC+1 

KSTRTB*KSTRTB+1 
GO  TO  30 

50  IF  (KSTRTB. GT.KSTOPB)  GO  TO  20 
DO  60  K*KSTRTB , KSTOPB 
XI (KC)*XI (K) 

V(KC)«V(K) 

KC*KC+1 
60  CONTINUE 
GO  TO  20 

70  IF  (KSTRTA.GT.KSTOPA)  GO  TO  20 
DO  80  K=KSTRTA , KSTOPA 
XI (KC)=XI (K) 

V(KC)=V(K) 

KC-KC+1 
80  CONTINUE 
GO  TO  20 


90  LSIZ£=ISIZE+LSIZE 

IF  (LSTRT2.NE.1)  GO  TO  10 
IF  aSIZE.LT.XTERMS)  GO  TO  10 
RETURN 


•  PHYSICAL  UTILITY  SOUTINES  •  AIS,PHELEV,PHAZIM, EAMENU  * 

SUBROUTINE  AIR(Z) 

AIR  IS  CALLED  TO  PROOUCE,  AT  A  SPECIFIED  ALTITUDE  WITHIN  A  SPECIFIED 
LAYER,  THE  VALUES  OF  THE  SOUND  SPEED  AND  WIND  VELOCITY,  THE  FIRST 
AND  SECOND  DERIVATIVES  OF  THOSE  QUANTITIES  WITH  RESPECT  TO  HEIGHT, 

AND  THE  DENSITY  OF  THE  ATMOSPHERE.  USES  LINEAR  INTERPOLATION  OF 
WINO  SPEED,  WINO  DIRECTION,  VIRTUAL  TEMPERATURE,  AND  GAMMA  WITH 
RESPECT  TO  GEOPOTENTIAL  HEIGHT;  THE  OTHER  QUANTITIES  ARE  DERIVED 
FROM  ALGEBRA  ANO  A  HYDROSTATIC  ASSUMPTION. 

REAL  Z,H,ZFACT 

REAL  OH, HI , H2, T ,DHW, H1W, H2W, SPD , THETA, ST , CT , DTHDH 

COMMON  /PTH/  NPTH, PRESS (97) , TMPMOLC97) , GPHCI97) , GAMMA(97) 

COMMON  /UINOS/  NU1NOS,GPHW(80) ,D IR(SO) ,TURN(79) , SPEED(80) 

COMMON  /LYRDEF/  NLAYER , GMZAC200) , I NDPTHC200) , I NDWNDC200 ) , 

♦  LYRPRT  <  200 ) , K LAYER , ZTOP , ZBOT 

LOGICAL  LYRPRT 
INTEGER  I NDPTH , 1NOWND 


COMMON  /ATMCON/  REARTH , GO , RSTAR ,R0M0, R0G0M0 

COMMON  /ATMSPH/  GAM, C, U, V,OCOZ,OUOZ,DVDZ,D2CDZ2, D2UDZ2,D2VDZ2, RHO 
REAL  GAM , C , U , V 
REAL  RADPOG 

COMMON  /PRESUR/  PRSSU,CC 
REAL  PRSSU.CC 

DATA  RADPOG/ 1 . 74532925 1 99433D ■ 2/ 


F1S<TAU)=U(TAU/5.  +  1.)*TAU/4.+1.)*TAU/3.*1.)*TAU/2.f1 . 
F1A(TAU)=(EXP<TAUM . 5/TAU 


NLPTH=INDPTH(KLAYER) 

NLWNO* I NDWND  (KLAYER ) 

ZFACT^I . 0+Z/REARTH 

H=Z/ZFACT 

DHOZ=1.0/ZFACT**2 

D2HDZ2- ■ 2. *DHDZ/(REARTH*ZFAC7 ) 

DH=GPHC(NLPTH*1)-GPMC(NLPTH) 

H1=(H-GPHC(Nl?TH))/DH 

H2=(GPHC(NLPTH*1 ) • H)/DH 

T=H1*TMPMOL(NLPTH*1)*H2*TMPMOL(NLPTH) 

0T0H  =  <  TMPMOL (NLPTH+ 1 ) • TMPMOLCNLPTH )  }/DH 


GAM=H1*GAMMA(HIPTH+1 )+H2*GAMMA(NLPTH) 
OGAMOH*( GA«MA < NLPTH* 1 ) • GAM«A< NLPTH ) )/DH 
C=SORT(GA#*R0M0*T) 
DCDH=.5*C*(DTDH/T+DGAH0H/GA>O 
02CDH2=- .25*C*C0GAMDH/GAM-0TDH/T)**2 
DCDZ=OCDH*OHOZ 

D2CDZ2=DCDH*02H0Z2+O2COH2*(DHDZ*«2) 
TAU=ALOG(T/TMPMOl(NLPTH) ) 

IF  (TAU.GT. .1 )  GO  TO  5 
FACTOR=TMPMOL(HLPT(0«F1S<TAIJ) 

GO  TO  10 

5  FACTOR=TMPMOUNLPTH)*F1A<TAU) 

1 0  PRS=PRE SS<  NLPTH )*EXP< - H 1 «0H/ ( ROGOHO'FACTOR ) ) 
PRSSU  *  (PRS) 

C  RHO=PRS/(T*ROMO) 

RHO=PRS«1 .0E3/<T*R0M0) 

DHU=GPHU(NLWND*1 )  -GPHUOdUNO ) 
H1U=<H-GPHW(NLWND) )/DNU 
H2V=(GPHU(NIWND+1 )-H)/OHU 
SP0=H1U*SPEED(NLWN0*1)+H2V»SPEED(Nl.WND) 

DSD Ha( SPEED (NLWNO+1 ) -  SPEED (NLUND ) )/DHU 

DTHDH*TURN(NLUND)*RADPOG 

THETA»0 1 R (NLUND )*RAOPOG+OT  HD H*H1W*D HW 

CT=COS(THETA) 

ST*SIN(THETA) 

U«-SPO*ST 

V»-SPO*CT 

DUOH=- SPO*CT*OTHOH-OSDH*ST 

DVDH=SPO*ST*DTHOH -OSDH*CT 

D2UDH2=OTHOH*(SPO*ST*OTHDH-2.*DSDH*CT) 

D2VDH2=0THDH*(SP0*CT*DTHDH+2.*DSDH*ST) 

DUOZ=OUDH*OHDZ 

DVDZ=OVDH*DHDZ 

D2U0Z2=0UDH«D2HDZ2+02UDH2*(DHDZ**2> 

D2VDZ2=0VDH*02H0Z2+02VDH2*CDH0Z**2) 

CC  =  C 
RETURN 
END 


c 

FUNCTION  PHELEV(DUMMY) 

C 

C  PHELEV,  GIVEN  THE  COMPONENTS  OF  THE  WAVE  NUMBER  VECTOR,  CALCULATES 
C  THE  ELEVATION  ANGLE  OF  THE  NORMALS  TO  THE  PHASE  SURFACES  OF  THE  WAVE. 
C 


COMMON  /RAYVAR/  ZD1R,PKK,RTPAA0,ATTEN, SIGMA, X,Y,Z,DAGE,XF,YF,ZF, 

♦  XT ,  YT ,  ZT ,  XS ,  YS ,  ZS ,  XSS ,  YSS ,  ZSS ,  XSSS ,  YSSS ,  ZSSS ,  P3 , 

♦  P3F,P3T,P3S,XFS,YFS,XTS, YTS,ZFTP3,XFTZ,YFTZ,ZFTZ, 

+  ZFA,ZTA,P3FTZ,P3FA,P3TA, AREA, DAGOS 

REAL  SIGMA.X, Y,Z,DAG£ ,XF , YF , ZF ,XT , YT , ZT 

DATA  DGPRAD/S7. 295780/ 

PMEL£V=OGPRAD*ATAN2(P3, RTPAAO) 

RETURN 

END 


c 

FUNCTION  PHAZIM(DUMMY) 

C 

C  PHAZIM,  GIVEN  THE  COMPONENTS  Of  THE  WAVE  NUMBER  VECTOR,  CALCULATES 
C  THE  AZIMUTH  ANGLE  Of  THE  NORMALS  TO  THE  PHASE  SURFACES  OF  THE  WAVE. 
C 

COMMON  /RAYNIT/  KGMH.NOCRVS.NUCRVS, IUPDWN,TQ,PH10,X0,Y0,Z0, 

+  P1O,P20lP30lOMEGA,OELTA0,PlF0,P2FO,P3F0,OMEGAF( 

♦  XTO, YTO,2TO,P1TO,P2TO,P3TO,OMEGAT,XSO, YS0,2S0, 

♦  P3S0 , RHO0 , PCONST , NAGES , AGES(20) 

INTEGER  KGMH , NOCRVS , NUCRVS , 1UPOUN 

DATA  DGPRAD/57. 295780/ 

PHAZIM=OGPRAD*ATAN2(-P10,-P20)*180. 

RETURN 

END 


c 

SU8R0UT I NE  EAMENUIELEV , AZ I M , MAG , EAST , NORTH , UP ) 

C 

C  EAMENU ,  GIVEN  THE  ELEVATION  ANGLE,  AZIMUTH  ANGLE,  AND  MAGNITUDE  OP  A 
C  VECTOR,  CALCULATES  THE  EAST,  NORTH,  AND  UPWARD  COMPONENTS  OF  THAT 
C  VECTOR. 

C 

REAL  MAG, NORTH, DGPRAO 
DATA  DGPRAD/57. 295780/ 

HSQ=£AST**2+NORTH«*2 
IF  (HSO.NE.0.)  GO  TO  5 
AZIM*0. 

GO  TO  10 

5  AZ IM=0GPRA0*ATAN2( -  EAST , -  NORTH )♦ 1 80 . 

IF  (AZIM.LE.O.)  AZIM=360. 

10  MAG=SQRT(HSQ*UP**2) 

IF  (MAG.LE.O.)  GO  TO  20 
HORIZ=SORT(HSG) 

ELEV*OGPRAO*ATAN2(UP , HOR 1 2 ) 

RETURN 
20  ELEV*0. 

RETURN 

END 


c 

C./  ADO  NAME*UNIT1S 

C 

C  SUBROUTINE  UNITS  CALLS  LOOKUP  TO  FIND  THE  CORRECT  CONVERSION  FACTO 
C  FOR  A  CIVEN  UNIT. 

C 

SUBROUT  I NE  UN  I T I S<  GI VEN , T ABLE , NT ABS , LCUN I T , TYPE , IDEFLT) 

CHARACTER'S  GIVEN , TA8LE<NTABS ) , TYPE , BLANK 
DATA  BLANK/'  '/ 

CALL  LOKUP(8,NTABS,TA8LE, GIVEN, LCUNIT,»5, *10) 

RETURN 

5  IF(GIVEN.EO. BLANK)  GO  TO  15 

WRITE<6,7)  GIVEN, TYPE, TABLE(LCUNIT) 

7  FORMAT ( 1  AMBIGUOUS  ABBREVIATION  ‘",A8,"'  FOR  •  .AS,  •  UNIT.  1  ", 
-A8, 1 ' '  ASSUMED.') 

RETURN 

10  URITE(7,12)  TYPE, GIVEN 

12  FORMAT  ( '  INVALID  ',A8,  *  UNIT  SPECIFIED  •,",A8,'".') 

STOP  650 

15  LCUNIT=IDEFIT 
RETURN 
END 


C3SnMISSS»3S313SSSM:Sll5SSHH33SS3S»SaS3ZS333SS:3S3SXS3S: 

c 

C  TABLE  LOOK  UP  ROUTINE 

C  SEARCH  TABLE  OF  CHAR  STRINGS  'KTABL'  FOR  MATCH  WITH  1 KTEST 
C  RETURN  1  FOR  BUNK  IN  FIRST  CHAR 

C  RETURN  2  FOR  NO  MATCH  FOUND 

C  NORMAL  RETURN  OR  RETURN  1,  MATCH  STRING  NUMBER  IN  'KTERM' 

C 

SUBROUT I NE  LOKUP ( NCHAR , NTE RMS , KTABL , KTE ST , KTERM , * , * ) 

CHARACTER*8  KTABL(NTERMS) ,  KTEST 
CHARACTER  BLANK, G 

DATA  BLANK/'  '/ 

C 

C  GET  FORST  CHARACTER  OF  STRING  AND  TEST  FOR  BLANK 
C 

G  *  KTEST(1 : 1 ) 

IF  (G.EQ. BLANK)  RETURN  1 
C 

C  SEARCH  TABLE  FOR  MATCH 
C 

KTERM  »  0 

DO  100  I  *  1.NTERMS 

IF  ( KTEST. EO.KTABLII ))  THEN 
KTERM  a  I 
RETURN 
END  I  F 

100  CONTINUE 
C 

C  NO  MATCH  FOUND 
C 

RETURN  2 
END 


c 

c 

CSS3CMSSS5SSS35SSSSSS3SS3SS322SS2SS535SSS2SSSSS3SSSSSS2SS25IS3SS3S3SS3S 

c 

C./  ADD  NAHE=FNDLYR 

C 

C  SUBROUTINE  FNDLTR  DEFINES  THE  LOCATION  OF  THE  LAYRE  IN  THE  ATMOSPH 
C  IN  UHICH  A  GIVEN  ALTITUDE  IS  LOCATED. 

C 

SUBROUTINE  FNOLYRCZ,*) 

COMMON  /LYROE F/NLAYER , GMZA<  200 ),! NDPTH  <  200) , 1 NDUND <  200 ) , 

♦LYRPRT (200) , KLAYER , 2T0P , 2B0T 
INTEGER  I NDPTH, INDUNO 
LOGICAL  LYRPRT 

CALL  GETLYR(2, GMZA , NLAYER , KLAYER , *50) 

ZBOT  =GHZA( KLAYER ) 

ZTOP=GMZA(KLAYER*1) 

RETURN 

50  RETURN  1 
ENO 


CsS3S3Xtl33S3n38a35SasSSSSSn3XZS3Z3a3a3«3ZS3X3SSras:SSSSSUS3SSSS25i 

c 

C./  ADD  NAME*GETLYR 

C 

C  SUBROUTINE  GETLYR  DOES  A  BINARY  TABLE  SEARCH  OF  THE  ATMOSPHERIC 
C  TA8LE  TO  FIND  THE  PROPER  LAYRE  INDEX. 

C 

SUBROUT I NE  GETLYRCX .XTABL , N I TEMS , NLAYR , *  > 

DIMENSION  XTABL (N ITEMS) 

IF(X.LT.XTABL(1))  RETURN  1 
IF(XTABL(N! TEMS ) . LT . X )  RETURN  1 

Nl*1 

N2=NITEMS-1 

IF(N2.LT.N1)  RETURN  1 

2  CONTINUE 

NLAYR-(N1*N2*1)/2 

I F(N2.EQ.N1 )  GO  TO  40 
I F(XTABL(NLAYR) -X)  5,40,10 

5  N1=NLAYR 
GO  TO  2 

10  N2=NLAYR-1 
GO  TO  2 

40  RETURN 
END 


c 

C./  ADD  NAME=T1MCVR 

C 

C  CONVERT  TIME  FROM  HHMMSS  TO  SSSSSS  AND  VICE-VERSA. 
FUNCTION  TIMCVR(T,KDIR) 

COMMON  /PRINTS/  TITLE<30) .TIMLBL 
CHARACTERS  TITLE 
CHARACTER'S  TIML8L 

COMMON  /PRINTC/  KTPSIG.CVRTIM 
LOGICAL  CVRT1M 

REAL  T,HMS,SS,SSS, HHMMSS 

REAL  ROUND ,  X ,  XNEAR ,  T I MCVR 

C 

C  STATEMENT  FUNCTIONS 
C 

SSS<HMS)=-2400.*AINT(HMS/1E4)-40.0*AINT<HMS/100.0>*HMS 
HHMMSS (SS)*4000 . 0*A I  NT ( SS/3600 . 0)+40 . 0*AI NT ( SS/60 . 0 )+SS 
R0UND(X,XNEAR)*SIGN(XNEAR’*AINT(ABS(X/XN£AR>*.50),X) 

IF  C . NOT . CVRT I M )  GO  TO  50 

IF  (KDIR.LE.1)  GO  TO  30 

T I MCVR=HHMMSS<  ROUND  <  T , .  1  )  ) 

RETURN 

30  TIMCVR=SSS(T) 

RETURN 

50  TIMCVR=T 
RETURN 


END 


c 

CSXSSSSSSSS313SSSSUXS2»11S»SX3SSSS33SSS::SS3S3MSSX3S3S23S33S3X3 

c 

C  REMOVE  HYPHEN  FROM  ACTYPE 
C 

SUBROUTINE  ACCVRT(ACTYP.CACTYP) 

CHARACTER'S  ACTYP,CACTYP,TAC,TCAC 
CHARACTER'1  AC(8),CAC(8) 

SOU I VALENCE  (TAC.AC), (TCAC.CAC) 

TAC  *  ACTYP 
TCAC  *  1  1 

I  *  0 
J  *  0 

100  CONTINUE 

1*1*1 
J  *  J  ♦  1 

IF  (AC( I ) .EQ. 1  -  1 )  THEN 
1*1*1 
END  IF 

CACCJ)  *  AC(I) 

IF  (I.LT.8)  GOTO  100 

CACTYP  =  TCAC 

RETURN 

ENO 


:sa 


VECTOR  MANIPULATION  ROUTINES 


FUNCTION:  DOT P 

PROGRAMMER:  PHILIP  J.  DAY 

PURPOSE:  TO  COMPUTE  THE  SCALER  PROOUCT  OF  TWO  N-OIMENTIONAL 

VECTORS 

FUNCTION  DOTP<V1 , V2, N) 

REAL  V1<N),V2(N) 

INTEGER  N 

REAL  OP 

OP  *  0.0 
00  TOO  I  *  1,N 

op  s  op  ♦  vi<n*v2<n 

100  CONTINUE 

OOTP  a  OP 

RETURN 

END 


c 

c 

C  FUNCTION:  RNORM 

C  PROGRAMMER:  PHILIP  J.  OAT 

C 

C  PURPOSE:  TO  COMPUTE  THE  VECTOR  NORM  OF  A  N-OIMENTIONAL  VECTOR 

C 

FUNCTION  RNORM(V1,N) 

REAL  VI (N) 

INTEGER  N 

REAL  0 

D  =  0.0 

DO  100  I  *  1,N 
0*0+  V1<I)**2 
100  CONTINUE 

RNORM  >  SQRT(O) 

RETURN 

END 


c 

C”323I3SJSSS3SSSSSSSS8SSSSSSSSSS2SS32SSS25S335SSSS3SS3t353SSa;SS3SSSS 

C 

C  SUBROUTINE:  CROSS 

C  PROGRAMMER:  PHILIP  J .  DAY 

C 

C  PURPOSE:  TO  COMPUTE  THE  VECTOR  PRODUCT  OF  TWO  3-DIMENTIONAL 

C  VECTORS 

C 

SUBROUTINE  CROSS(V1 ,V2,CP) 

REAL  Vl<3),V2(3),CP<3) 

CP(1)  *  VI (2)*V2(3)  •  VI (3)*V2(2) 

CP(2)  *  VI (1 )*V2(3)  -  V1(3)*V2(1) 

CP( 3)  =  V1(1 )*V2(2)  -  VI C2)»V2< 1 J 


RETURN 

END 


£**«******»***»»*»#«»****  ***«*' 

£*.•••••••••*.  END  VECTOR  ROUTINES 

£**************«**«******  ***** 


c 

c 

C«SSS33S3SSSS3SSSS3SS:SS33»Z33SSSZ:S:5S:SSS3:S1S33SSS2S£351SS=3SSSS 

c 

C  DOUBLE  PRECISION  VECTOR  MANIPULATION  ROUTINES 

c 

C3333233333233333333Z323333X33322333333533333S3333332333333333333333 

c 

C  FUNCTION:  DDOTP 

C  PROGRAMMER:  PHILIP  J.  DAY 

C 

C  PURPOSE:  TO  COMPUTE  THE  DOUBLE  PRECISION  SCALER  PROOUCT  OF  TWO 

C  N-DIMENT IONAL  VECTORS 

C 
C 

DOUBLE  PRECISION  FUNCTION  DOOTP<V1 , V2,N> 

DOUBLE  PRECISION  Vl<N),V2(N> 

INTEGER  N 

DOUBLE  PRECISION  DP 

DP  *  0.0 

DO  100  I  «  1,N 

DP  *  DP  +  VI ( I )*V2( I ) 

100  CONTINUE 

DOOTP  3t  OP 


RETURN 


c 

Cin2n»ts»zi3Sun»ii«»it3Ssi3iisuHsK»3sasiia3ii»issisisti« 

c 

c 

C  FUNCTION:  08 NORM 

C  PROGRAMMER:  PHILIP  J.  DAY 

C 

C  PURPOSE:  TO  COMPUTE  THE  OOUBLE  PRECISIONVECTOR  NORM  OF  A 

C  N-QIMENTIONAL  VECTOR 

C 

DOUBLE  PRECISION  FUNCTION  DRNORMCV1 ,N) 

OOUBLE  PRECISION  VI (N) 

INTEGER  N 

OOUBLE  PRECISION  D 

0  »  0.0 

DO  100  I  *  1,N 
0  *  D  ♦  V1(I)**2 
100  CONTINUE 

DRNORM  x  DSQRT(D) 

RETURN 

ENO 


c 

Q8SS;SSSSSSS«S3SSSS38S2SS3SSS38SSSS«33SSSS: 

c 

C  SUBROUTINE:  DCROSS 

C  PROGRAMMER:  PHILIP  J.  OAY 

C 

C  PURPOSE:  TO  COMPUTE  THE  DOUBLE  PRECISION  VECTOR  PROOUCT  OF 

C  TWO  3-OIMENTIONAL  VECTORS 

C 
C 

SUBROUTINE  DCROSS ( VI ,V2, CP) 

DOUBLE  PRECISION  V1<3),V2(3),CP(3) 

CP<1)  *  VI (2)*V2(3)  •  V1(3)*V2(2) 

CP(2)  *  V1(1)*V2(3)  •  VI (3)*V2(1 > 

CPC  1 >  *  VI (1 )*V2(2)  •  Vl(1 )*V2(2) 

RETURN 

END 


Cnsatasaauasssssvnsngsasssss*: 

c 

C  SUBROUTINE:  DUN  IT 

C  PROGRAMMER:  PHILIP  J.  OAY 

C 

C  PURPOSE:  TO  COMPUTE  A  DOUBLE  PRECISION  UNIT  VECTOR,  VHAT,  IN  THE 

C  SAME  DIRECTION  AS  VI. 

C 

C 

SUBROUTINE  DUNIT(V1,VHAT,N) 

DOUBLE  PRECISION  V1(N),VHAT(N) 

INTEGER  N 

DOUBLE  PRECISION  A 

A  *  RNORM(V1,N) 

DO  100  l  *  1,N 
VHAT(I)  «  Vl(l)/A 
100  CONTINUE 


RETURN 

END 


c 

0 


C*************  END  DOUBLE  PRECISION  VECTOR  ROUTINES  ************* 


£**«nn»*«****«************  ************************* 

C3:s:3s:s=ss:=:ss3s::=:3sssss:ss=::s:::3::::::::s23s3:5s:;:::s::=:szs 

c 

SUBROUTINE  FFT  (A,  B,  NTOT,  N,  NSPAN,  ISN) 


QM4 

c 

c  PURPOSE: 

C 

C  MULTIVARIATE  COMPLEX  FOURIER  TRANSFORM. 

C 

C  MULTIVARIATE  COMPLEX  FOURIER  TRANSFORM,  COMPUTED  IN  PLACE  USING 

C  MIXED-RADIX  FAST  FOURIER  TRANSFORM  ALGORITHM.  MULTIVARIATE  DAT 

C  INDEXED  ACCORDING  TO  THE  FORTRAN  ARRAY  ELEMENT  SUCCESSOR  FUNCTI 

C  WITHOUT  LIMIT  ON  THE  NUMBER  OF  IMPLIED  MULTIPLE  SUBSCRIPTS.  TH 

C  SUBROUTINE  IS  CALLED  ONCE  FOR  EACH  VARIATE.  THE  CALLS  FOR  A  MU 

C  VARIATE  TRANSFORM  MAY  BE  IN  ANY  ORDER. 

C 

C  CATEGORIES: 

C 

C  CFT  MIXED_RAOIX_FFT  FAST_FOUR I ER_TRANSFORM 

C 

C  REFERENCES: 

C 

C  CALL  FFT  (A,  B,  NTOT,.  N,  NSPAN,  ISN) 

C 

C  ARGUMENTS: 

C 

C  *A  (1 :NTOT)  REAL 

C  ARRAYS  A  AND  B  ORIGINALLY  HOLD  THE  REAL  AND  IMAGINARY  COMPON 

C  OF  THE  DATA,  AND  RETURN  THE  REAL  AND  IMAGINARY  COMPONENTS  OF 

C  RESULTING  FOURIER  COEFFICIENTS. 

C 

C  *B  (1 :NTOT)  REAL 

C  SEE  ARRAY  A,  ABOVE. 

C 

C  -NTOT  INTEGER 

C  TOTAL  NUMBER  OF  COMPLEX  DATA  VALUES  IN  ARRAYS  A  AND  B. 

C 

C  -N  INTEGER 

C  THE  LENGTH  OF  DIMENSION  ALONG  WHICH  IT  IS  DESIRED  TO  TRANSFO 

C 

C  -NSPAN  INTEGER 

C  THE  LENGTH  OF  THE  TRANSFORM  TIMES  THE  SPACING  BETWEEN  ELEMEN 

C 

C  -ISN  INTEGER 

C  DETERMINES  THE  SIGN  OF  THE  COMPLEX  EXPONENTIAL.  THE  MAGNITUD 

C  OF  ISN  IS  NORMALLY  ONE. 

C 

C  INDICATES  AN  INPUT  PARAMETER; 


C  INDICATES  BOTH  AN  INPUT  AND  OUTPUT  PARAMETER. 

C 

C  EXTERNALS: 

C 

C  NONE 

C 

C  FILES: 

C 

C  ♦DEFAULT  DEFAULT  SEQUENTIAL  FORMATTED 

C  ERROR  MESSAGE  IF  HIGHEST  PRIME  FACTOR  OF  M  IS  GREATER  THAN  2 

C 

C  “♦“  INDICATES  OUTPUT  ONLY. 

C 

C  COMMONS: 

C 

C  NONE 

C 

C  DEPENDENCIES: 

C 

C  IF  THE  INPUT  DATA  IS  REAL,  SEE  'REALTR 1  PROLOGUE. 

C 

C  EXAMPLES: 

C 

C  A  TRI -VARIATE  TRANSFORM  WITH  A(N1,  N2,  N3),  B(N1,  N2,  N3) 

C  IS  COMPUTED  BY: 

C 

C  CALL  FFT  (A,  B,  N1*N2*N3,  N1 ,  N1,  1) 

C  CALL  FFT  (A,  B,  N1*N2*N3,  N2,  N1*N2,  1) 

C  CALL  FFT  (A,  B,  N1*N2*N3,  N3,  N1*N2*N3,  1) 

C 

C  FOR  A  SINGLE -VAR  I  ATE  TRANSFORM  WITH  NTOT  *  N  =  NSPAN  *  (NUMBER 

C  COMPLEX  OATA  VALUES),  FOR  EXAMPLE: 

C 

C  CALL  FFT  (A,  B,  N,  N,  N,  1) 

C 

C  THE  DATA  MAY  ALTERNATELY  BE  STORED  IN  A  SINGLE  COMPLEX  ARRAY  A, 

C  THE  MAGNITUDE  OF  1SN  CHANGED  TO  TWO  TO  GIVE  THE  CORRECT  INDEXIN 

C  INCREMENT  ANO  A<2)  USED  TO  PASS  THE  INITIAL  ADDRESS  FOR  THE 

C  SEQUENCE  OF  IMAGINARY  VALUES;  FOR  EXAMPLE: 

C 

C  CALL  FFT  (A,  A<2),  NTOT,  N,  NSPAN,  2) 

C 

C  NOTES: 

C 

C  ARRAYS  AT(MAXF),  CX(MAXF),  BT(MAXF),  SK(MAXF) ,  AND  NP(MAXP)  ARE 

C  USED  FOR  TEMPORARY  STORAGE.  IF  THE  AVAILABLE  STORAGE  IS  INSUF- 

C  FICIENT,  THE  PROGRAM  IS  TERMINATED  BY  A  STOP. 

C  MAXF  MUST  BE  . GE.  THE  MAXIMUM  PRIME  FACTOR  OF  N. 

C  MAXP  MUST  BE  .GE.  THE  NUMBER  OF  PRIME  FACTORS  OF  N. 

C  IN  ADO  I T ION ,  IF  THE  SQUARE-FREE  PORTION  K  OF  N  HAS  TWO  OR  MORE 

C  PRIME  FACTORS,  THEN  MAXP  MUST  BE  .GE.  K  •  1. 

C 

C  ARRAY  STORAGE  IN  NFAC  FOR  A  MAXIMUM  OF  11  FACTORS  OF  N.  IF  N  HA 

C  MORE  THAN  ONE  SQUARE -FREE  FACTOR,  THE  PROOUCT  OF  THE  SQUARE -FRE 


FACTORS  MUST  BE  .LE.  210. 


C 

c 

C  LIMITATIONS: 

C 

c  THE  HIGHEST  PRIME  FACTOR  OF  M  MUST  HOT  EXCEED  23. 

C 

C  HISTORY: 

C 

C  R.  SINGLETON  01OCT68  STANFORD  RESEARCH  INSTITUTE. 

C  M.  FORSTER  16NOV76  ADDED  TO  LIBRARY. 

C 

C*** 

C 

DIMENSION  A(1024)  ,80  024) 

DIMENSION  NFAC(11),NP(255) 

DIMENSION  AT(23),CK(23),BT(23),SK(23) 

EQUIVALENCE  (1,11) 

C 

C  THE  FOLLOWING  TWO  CONSTANTS  SHOULD  AGREE  WITH  THE  ARRAY  DIMENSIONS, 
C 

MAXF*23 

MAXP*255 

IF(H  .LT.  2)  RETURN 
1NC*ISN 

RAD*8.0*ATAN<1.0) 

S72*RAD/5.0 

C72*COS(S72) 

S72=SIN(S72) 

S120*SORT(0.75) 

I F( ISN  .GE.  0)  GO  TO  10 
S72*-S72 
S120-S120 
RAD* -RAD 
INC*- INC 
10  NT*INC*NTOT 
KS=INC*NSPAN 
KSPAN*KS 
NN*NT- INC 
JC*KS/N 

RADF*RAD*FLOAT(JC)*0.5 

1*0 

JF*0 

C 

C  DETERMINE  THE  FACTORS  OF  N 
C 

M*0 

X*N 

GO  TO  20 
15  M=M+ 1 

NFAC(M)=4 

K*K/16 

20  1  F(K- (K/16)*16  .EQ.  0)  GO  TO  15 
J*3 


GO  TO  30 


25  M*M*1 
MFAC{M)«J 
K*K/JJ 

30  !F(MOO(K,JJ)  .EO.  0)  GO  TO  25 
j«j+2 
JJ*J**2 

1F(JJ  .LE.  K)  GO  TO  30 
IFOC  .GT.  4)  GO  TO  40 
ICT*M 

NFAC(M*1 )*K 
I FOC  .ME.  1)  M*M+1 
GO  TO  80 

40  lF(K-<K/4)*4  .ME.  0)  GO  TO  50 
M*M*1 
NFAC(H)*2 
K*IC/4 
50  KT*M 
J»2 

60  IF(MOO(K,J)  .ME.  0)  GO  TO  70 
M*M*1 
NFAC(M)*J 
IC«tC/J 

70  J»<(J+1 )/2)*2+1 

I F C J  .LE.  1C)  GO  TO  60 
80  IFOCT  .EG.  0)  GO  TO  100 
J-KT 
90  M*M+1 

MFAC(M)-MFACCJ) 

J=J-1 

I F< J  .ME.  0)  GO  TO  90 
C 

C  COMPUTE  FOURIER  TRANSFORM 
C 

100  SD*RADF/FLOAT (KSPAN) 

CD*2.0*SIN(SO)**2 

S0*S1N(S0*S0) 

KK*1 

1*1*1 

I F(NFAC( 1 )  .HE.  2)  GO  TO  400 
C 

C  TRANSFORM  FOR  FACTOR  OF  2  {INCLUDING  ROTATION  FACTOR) 
C 

ICSPAN*KSPAN/2 
K1*KSPAN*2 
210  K2*KK+KSPAN 
AK*A(K2) 

BK=8<K2) 

AOC25=AOCKO-AK 
8(K2)=8(KK)  • BK 
A<KIO*AOCIO*AK 
8<K)0*8{KK)*8<C 
KK=K2*KSPAN 

I F(KK  .LE.  MN)  GO  TO  210 


KKZKK-NM 

! F(KK  .LE.  JC>  GO  TO  210 
IFOOC  .ST.  KSPAN)  GO  TO  800 
220  C1«1.0-CD 
S1*SO 

230  IC2=KK+KSPAN 
AK=A(KK)-A(K2) 

BK380CK) -BOC2) 

AOOO=AOOO+AOC2) 

8000*8000+80(2) 

AOC2)*C1*AK-S1*8K 
8  OC2 ) *S 1 * AK+C 1 *8K 
IOC*K2+KSPAN 

IFOOC  .LT.  NT)  GO  TO  230 

K2*KK-NT 

C1*-C1 

KK*IC1-IC2 

IFOOC  .GT.  K2)  GO  TO  230 
AK*C1 ■ (CD*C1+SD*S1 ) 

S1=<SO*C1-CO*S1)+S1 

c 

C  THE  FOLLOWING  THREE  STATEMENTS  COMPENSATE  FOR  TRUNCATION 
C  ERROR.  IF  ROUNDED  ARITHMETIC  IS  USED,  SUBSTITUTE 

C  C1*AK 

C 

C1*0.5/(AK**2+Sl**2)+0.5 

S1*C1»S1 

C1*C1*AK 

KK=KK+JC 

IFOOC  .LT.  K2)  GO  TO  230 
K1=K1*INC+INC 
KK=OC1-KSPAN)/2*JC 
IFOOC  .LE.  JC+JC)  GO  TO  220 
GO  TO  100 
C 

C  TRANSFORM  FOR  FACTOR  OF  3  (OPTIONAL  COOE) 

C 

320  K1  *<K*KSPAN 
K2=K1+KSPAN 
AK=A(ICIO 
BK*B(KK) 

AJ*AOC1)+A()C2) 

BJ=BOC1)+8<)C2) 

A(KK)*AK+AJ 

BOOO*8K+BJ 

AIC3-O.S*AJ+AK 

8K*-0.5*BJ+8IC 

AJ=(AOC1)AOC2))*S120 

BJ  =  (B(K1)-B<IC2))*S120 

AOCD-AK-SJ 

BOC1  )=BK+AJ 

A(K2)=AK+8J 

3  C  K2 ) =8tC  -  A  J 

K)C=IC2*ICSPAN 


IF(KK  .IT.  NN)  00  TO  320 
KK*KK-NN 

1F0CK  . LE.  KSPAN )  GO  TO  320 
GO  TO  700 
C 

C  TRANSFORM  FOR  FACTOR  OF  4 
C 

400  IF<NFAC( I )  .NE.  4)  GO  TO  600 
KSPNN-ICSPAN 
KSPAN*KSPAN/4 
410  C1*1.0 
S1«0 

420  IC1  *KK+KSPAN 
K2*K1*KSPAN 
IC3*IC2*KSPAN 
AKP”A(KK)+A()C2) 

AKM«A(KK)-A(K2) 

AJP«A(K1)+A<K3) 

AJM*A<K1  )-A(K3) 

A(KIO*AICP*AJP 

AJP*AKP-AJP 

BKP»BOCIC)+8(IC2) 

BKM*B(KK)-B(K2) 

BJP*B(K1  )-»8<IC3) 

BJM»8(K1 ) -BOG) 

8<KK)*8KP*BJP 

SJP*BICP-8JP 

I F < I SN  .LT.  0)  GO  TO  450 

AKP*AKM-BJM 
AKM<AKM*BJM 
8KP*8KM*AJM 
BKM*BKM- AJM 

I  F(S1  .EQ.  0.0)  GO  TO  460 
430  A(K1)*AKP*C1-BICP*S1 
8(K1  )*>AKP*S1+8KP*C1 
A( K2 )*A JP*C2 • 8 JP*S2 
B<  K2 )»A JP*S2+8JP*C2 
AOC3)»AKM*C3-BKM*S3 
B(K3)*AICM*S3»8KM*C3 
kk*k3+kspan 

1  F(KK  .LE.  NT)  GO  TO  42u 
440  C2*C1-(CO*C1+SO*S1) 

S1=>(SO*C1-CO*S1)*S1 

C 

C  THE  FOLLOWING  THREE  STATEMENTS  COMPENSATE  FOR  TRUNCATION 
C  ERROR.  IF  ROUNDED  ARITHMETIC  IS  USED,  SUBSTITUTE 

C  C1=C2 
C 

C1=0.5/(C2**2*S1**2)+0.5 

S1=C1*S1 

C1=C1*C2 

C2=C1**2- S1*»2 

S2-2.0*C1*S1 

C3=C2*C1S2*S1 


S3*C2*S1+$2*C1 

KX*iCK-NT+JC 

IFOCK  .LE.  KSPAN )  GO  TO  420 
KKzOC-KSPAN+tNC 
!FO«  .LE.  JC)  GO  TO  410 
1 F (KSPAN  .EQ.  JC)  GO  TO  300 
GO  TO  100 

450  AKP*AOK8JM 
AKMaAKM-BJM 
BKP-BKM-AJM 
BKM-8KH+AJM 

I F(S1  .ME.  0.0)  GO  TO  430 

460  A(IC1)*AKP 
B(K1)*8KP 
A(K2)*AJP 
B(K2)«BJP 
A(K3)=AKM 
B(K3)*BKM 
KK*K3+KSPAN 

I  F(KK  .IE.  NT)  GO  TO  420 
GO  TO  440 

C 

C  TRANSFORM  FOR  FACTOR  OF  5  (OPTIONAL  COOE) 

c 

510  C2*C72**2 - S72**2 
S2*2.0*C72*S72 

520  Kl*KK*KSPAN 
JC2=K1+KSPAN 
K3*K2*KSPAN 
K4=K3+KSPAN 
AKP=A(K1)+A(K4) 

AKM*A(K1)-A(K4) 

BKP'BCKI )*B(K4) 

BKM*8(K1 ) ’B(X4) 

AJP«A<K2)+A(K3) 

AJM*A(K2)'A(K3) 

BJP*8(K2)*B(K3) 

BJM*8(K2) ’BCK3) 

AA*A(KK) 

88*8000 

A(KK)*AA+AKP+AJP 

B(KK)*88+8KP*8JP 

AK*AKP*C72*AJP*C2*AA 

8K=8KP*C72+8JP*C2-»8B 

AJ*AKM*S72*AJM*$2 

8J*8KM*S72*8JM*S2 

A(K1)*AK-8J 

A(K4)*AK*BJ 

BOO  )*3K*AJ 

B(K4)=8K-AJ 

AK=AKP»C2*AJP*C72*AA 

3K=8KP*C2*8JP*C72*8B 

AJ*AKM*S2- AJM*S72 

BJ=8KM*S2 ■ 8JM*$72 


AOC2)*AK-8J 

A<K3)*AK+8J 

8(K2)*8K+AJ 

8(K3)*8K-AJ 

I0C-K4+KSPAN 

I  FOOC  .LT.  NN)  GO  TO  520 
KK*KK-NN 

I F < KK  .IE.  KSPAN)  GO  TO  520 
GO  TO  700 
C 

C  TRANSFORM  FOR  000  FACTORS 
C 

600  K*NFAC( I ) 

KSPNN«KSPAN 
ICSPAN*KSPAN/K 
I F(K  .EQ.  3)  GO  TO  320 
IFCK  .EQ.  5)  GO  TO  510 
IFOC  .EQ.  JF)  GO  TO  640 
JF*K 

S1=RAO/FUOAT<IO 

C1*COS(S1) 

Sl*$IN(S1 ) 

I F< JF  .GT.  MAXF)  GO  TO  998 
CK( JF)*1 .0 
SK( JF)«0.0 
J»1 

630  CK(J)-CK(IO*C1+SK()C)*S1 
SK(J)*CK(K)*S1  -SK(IC)*C1 
K><-1 

CK(K)*CK( J) 

SK(K)*-SK(J) 

J»J*1 

!F< J  .LT.  K)  GO  TO  630 
640  K1*KK 

K2=KK+KSPNN 

AA«A()CK) 

B8»8<»CIO 

AK*AA 

BK>88 

J*1 

K1=K1+KSPAN 
650  K2-<2-tCSPAN 
J»J*1 

AT<J)=A(IC1)*A<IC2) 
AK=AT(J)+A)C 
BT(J)*B<K1  )*8(IC2) 

8K=8T ( J )+8K 

J*J+1 

AT(J)=A(K1)-A(K2) 

BT<  J  )=8(K1 ) -BOC2) 
K1=K1+KSPAN 

1 F(K1  .LT.  <2)  GO  TO  650 

A(KK)=AK 

B<KK}=8(C 


K1*KK 

K2*KK+KSPNN 

J*1 

660  K1=K1+ICSPAN 
K2=K2-KSPAN 
JJ*J 
AK*AA 
8K*88 
AJ*0.0 
8J*0.0 
K*1 

670  K*K+1 

AK»AT  (  K)*CK  (  J  J  )*AIC 
8K=8T(K)«CK(JJ)+BK 
K=K+ 1 

A J*AT(K)*SK<  J J  )+AJ 
BJ*BT(IO*SK(JJ)+8J 

IF( JJ  .GT.  JF>  JJaJJ-JF 

IF(IC  .LT.  JF5  GO  TO  670 

K*JF-J 

A(K1)«AK-BJ 

80C1)*8K+AJ 

A<K2)»AIC+8J 

B(K2)»8K-AJ 

J*J*1 

IF(J  .IT.  K)  GO  TO  660 
KK=KK+ICSPNN 

IFOCK  .  LE.  NN)  GO  TO  640 
KK=KK-NN 

IFOCK  .LE.  KSPAN)  GO  TO  640 
C 

C  MULTIPLY  BY  ROTATION  FACTOR  (EXCEPT  FOR  FACTORS  OF  2  AND  4) 
C 

700  IF( I  .EQ.  M)  GO  TO  800 
KK=JC+1 
710  C2=1.0 -CD 
S1*SO 
720  C1«C2 
S2*S1 

KK*KK+KSPAN 
730  AK=A(KK) 

A  (  KK )  =C2* AK  ■  S2*8 ( KK ) 

B(KK)=S2*AK+C2*8(KK) 

KK=KK+KSPNN 

I  F(KK  .LE.  NT)  GO  TO  730 

AK*S1*S2 

$2=S1*C2+C1*S2 

C2=C1*C2-AK 

KK=KK-NT+KSPAN 

I  F(KK  .LE.  KSPNN )  GO  TO  730 

C2=C1 - (CD*C1*S0*S1 ) 

S1=S1+(SD*C1-CD*S1) 


c 


C  THE  FOLLOWING  THREE  STATEMENTS  COMPENSATE  FOR  TRUNCATION 
C  ERROR.  IF  ROUNOED  ARITHMETIC  IS  USED,  THEY  MAY 
C  BE  DELETED. 

C 

C1*0.5/(C2**2+S1**2)+0.5 
S1-C1*S1 
C2=C1*C2 
KK*KK  ■  KSPNN+JC 
1  F(KK  .LE.  KSPAN)  GO  TO  720 
KK*KK- KSPAN* JC*  l  NC 
IFOCK  .LE.  JC+JC)  GO  TO  710 
GO  TO  100 
C 

C  PERMUTE  THE  RESULTS  TO  NORMAL  ORDER- ■ -DONE  IN  TWO  STAGES 
C  PERMUTATION  FOR  SQUARE  FACTORS  OF  N 
C 

800  NP(1 )*KS 

IFOCT  .EQ.  0)  GO  TO  890 
K*KT+KT+1 

IFCM  .LT.  K)  KaK- 1 
J*1 

NPOC+1  )*JC 

810  NP<J*1)*NP<J)/NFAC(J) 

NP(K)*NP(K*1 )*NFAC( J ) 

J=J*1 
K*K- 1 

IF(J  .LT.  K)  GO  TO  810 
K3=NP(K+1 ) 

KSPAN-NP<2) 

KK>JC*1 

K2=KSPAN+1 

J=*1 

IF(N  .NE.  NTOT)  GO  TO  850 
C 

C  PERMUTATION  FOR  SINGLE-VARIATE  TRANSFORM  (OPTIONAL  CODE) 
C 

820  AK=A(KK) 

A<KK)«A(K2) 

A(K2)*AK 

BK*8(KK) 

B<KK)*8(K2) 

8<K2)«8K 

KK*KK+INC 

K2*KSPAN*K2 

I  F(K2  .LT.  KS)  GO  TO  820 
830  K2«K2-NP(J) 

JsJ+1 

K2»NP<J+1)*K2 

I  F(K2  .GT.  NP(J))  GO  TO  830 
J=1 

840  IF(KK  .LT.  K2)  GO  TO  820 
KK=KK*INC 
K2=KSPAN+K2 

IF<K2  .LT.  KS)  GO  TO  840 


IFCKK  .LT.  KS)  GO  TO  330 
JOO 
GO  TO  890 
C 

C  PERMUTATION  FOR  MULTIVARIATE  TRANSFORM 
C 

850  KaKK+JC 
860  AK*A(KK) 

A(KK)*ACK2) 

A(K2)*AK 

BK*8CKK) 

B(IQC)«80C2) 

S(K2)«8K 

KKaKK+INC 

K2*K2+INC 

IFCKK  .IT.  K)  GO  TO  860 

KK*KK+KS-JC 

K2=K2+KS-JC 

IFCKIC  .LT.  NT)  GO  TO  850 

K2aK2-NT+KSPAN 

KK*KK-NT*JC 

IF(K2  .LT.  KS)  GO  TO  850 
870  K2*K2-NP(J) 

J»J+1 

K2*NP(J+1 )+K2 

IFCK2  .GT.  NPCJ))  GO  TO  870 
J*1 

880  IFCKIC  .LT.  K2)  GO  TO  850 
KK-KK+JC 
K2aKSPAN+K2 

IFCK2  .LT.  KS)  GO  TO  880 
IFCKK  .LT.  KS)  GO  TO  870 
JC=K3 

890  1FC2*KT*1  .GE.  M)  RETURN 
KSPNNaNPCKT»1 ) 

C 

C  PERMUTATION  FOR  SQUARE- FREE  FACTORS  OF  N 
C 

J*M-KT 
NFACC J+1 )a1 

900  NFACCJ)*NFACCJ)*NFACCJ+1) 

JaJ-1 

IFCJ  .ME.  KT)  GO  TO  900 

KT*KT*1 

NN*NFACCICT)- 1 

IFCNN  .GT.  MAXP)  GO  TO  998 

JJ-0 

J*0 

GO  TO  906 
902  JJ-JJ-K2 
K2-KK 
K*K+1 

KK-NFACCK) 

904  JJaKK+JJ 


IFCJJ  .  GE.  X2)  GO  TO  902 
NP<  J )»J  J 
906  X2*NFAC(XT) 

X»XT+1 

XX-NFACCX) 

J=J+1 

IFCJ  .IE.  NN)  GO  TO  904 
C 

C  DETERMINE  THE  PERMUTATION  CYCLES  OF  LENGTH  GREATER  THAN  1 
C 

J«0 

GO  TO  914 
910  X«XX 

XK*NP(X) 

NP<X)*-XK 

IFCXK  .HE.  J)  GO  TO  910 
X3*XX 
914  J*J+1 
KK*NP( J) 

IFOOC  .LT.  0)  GO  TO  914 
IFOCIC  .NE.  J)  GO  TO  910 
NPCJ)*-J 

IF(J  .NE.  NN)  GO  TO  914 
MAXF»INC*MAXF 
C 

C  REORDER  A  AND  B,  FOLLOWING  THE  PERMUTATION  CYCLES 
C 

GO  TO  950 
924  JmJ-1 

IF(NPCJ)  -LT.  0)  GO  TO  924 
JJ*JC 

926  KSPAN-JJ 

IFCJJ  .GT.  MAXF)  XSPAN=MAXF 

JJ«JJ-XSPAN 

X*NP< J) 

XX*JC*X+I I+JJ 

X1*XX+XSPAN 

X2=0 

928  X2*X2+1 

ATCX2)*ACX1) 

BT(X2)*8(X1) 

X1»X1* INC 

I F(IC1  .NE.  ICX)  GO  TO  928 
932  X1=XX+XSPAN 

X2*X1 • JC*CX+NP(X) ) 

X*-NP(X) 

936  ACX1 )*A(X2) 

B(X1 )=B(X2) 

X1=X1 • INC 
K2=X2- INC 

I  FOCI  .NE.  XX)  GO  TO  936 
XX*X2 

I F(X  .NE.  J)  GO  TO  932 
X1=XX+XSPAN 


K2«0 

940  K2-K2+1 

A(K1)»AT(K2) 

B(K1)*STOC2) 

IC1*K1  •  INC 

I  FOCI  .ME.  CIO  GO  TO  940 
IFCJJ  .ME.  0)  GO  TO  926 
IF(J  .ME.  1)  GO  TO  924 
950  J*K3+1 

NT«NT-KSPNN 
I I*NT- INC+1 

I F <NT  .GE.  0)  GO  TO  924 
RETURN 
C 

C  ERROR  FINISH,  INSUFFICIENT  ARRAY  STORAGE 
C 

998  ISN«0 
PRINT  999 
STOP 

999  FORMAT ( 1  ERROR  FFT,  INSUFFICIENT  ARRAY  STORAGE') 
END 


•**»■•*••«•»**»•*»»**«***»**  SUBROUTINE  CALSEL  ************************** 

a*********************************************************************** 

*-  MOOULE  NAME  :  CALSEL 
*-  MOOULE  TYPE  :  SUBROUTINE 

•-  PROGRAMMER  :  THOMAS  REILLY 
*-  DATE  :  MARCH  4,  1987 

*•  REVISIONS  : 

•-  DESCRIPTION  : 

*-  THIS  SUBROUTINE  IS  DESIGNED  TO  CALCULATE  THE  CSEL 

*•  FROM  THE  SIGNATURE.  THIS  IS  DONE  8Y  FIRST  REMOVING  THE 

*-  SHOCKS  FROM  THE  INPUTED  PRESSURE  ARRAY  AND  THEN  DOING 

•-  AN  F FT  ON  THE  ARRAY.  THE  CSEL  VALUE  IS  THEN  COMPUTED 

*-  FROM  THE  FFT  OUTPUT. 


MOOULE  I/O  :  CALSELCPRESS,  PTIME,  NPTS,  CSEL) 


INPUTS  : 

NPTS  ■  INTEGER  :  NUMBER  OF  POINTS  IN  PRESS  AND  PTIME. 

PRESS  •  REAL (504)  ;  ARRAY  CONTAINING  THE  SIGNATURE  PRESSURES 

PTIME  •  REAL (504)  :  ARRAY  CONTAINING  THE  TIME  ASSOCIATED  W/P 


OUTPUTS  : 

CSEL  •  REAL 


:  CALCULATED  SOUND  EXSPOSURE  LEVEL  IN  DB. 


VARIABLE  01  Cl TON ARY  : 


CF 

•  REAL 

:  USED  TO  COMPUTE  THE  C-WE1GHTED  SPECTRUM 

EIND 

-  INTEGER 

:  VALUE  OF  THE  LAST  INDICE  NEEDED  IN  THE  S 

TIME  ARRAY. 

ETIME2 

-  INTEGER 

:  END  OF  SECOUND  TIME  ARRAY  WITH  A  VALUE  L 

THAN  PTIME(NPTS). 

GF 

•  REAL 

:  USED  TO  COMPUTE  THE  MEAN  SQUARE  SOUND  PR 

LEVEL  AT  FREQUENCY  F  FOR  BANDWIDTH  (1/T) 

ICNT 

•  INTEGER 

:  LOOP  CONTOL  VARIABLE. 

LCE 

-  REAL 

:  USED  FOR  SUMATION  OF  THE  C-WEIGHTED  SOUN 

EXPOSURE  LEVEL. 

MAXIND 

-  INTEGER 

:  ARRAY  INDICE  FOR  THE  MAX  PRESSURE. 

MPRESS 

-  REAL 

:  MAX  PRESSURE  VALUE. 

PRESS2 

•  REAL (1024) 

:  SECOUND  PRESSURE  ARRAY  WITH  INTERPOLATE 

PTIME2 

•  REALC 1024) 

:  SECOUND  TIME  ARRAY  WITH  T  INCREMENTS  OF 

SCOUNT 

■  INTEGER 

:  NUMBER  OF  SHOCKS  THAT  HAVE  BEEN  FOUND. 

SIND 

-  INTEGER 

:  STARTING  INDICE  FOR  THE  SECOUND  TIME  ARR 

STIME2 

•  INTEGER 

:  START  OF  SECOUND  TIME  ARRAY  WITH  A  VALUE 

GREATER  THAN  PTIME(I). 

TCNT1  •  INTEGER  :  COUNTER  FOR  THE  PT1ME2  ARRAY. 
TCNT2  •  INTEGER  :  COUNTER  FOR  THE  PT1ME  ARRAY. 
TCNT3  •  INTEGER  :  COUNTER  FOR  THE  PTINE  ARRAY. 


CALLING  HCOULES  : 


CALLED  MOOULES  : 


FPT (PRESS2,  PRESS,  NPTS,  NPTS,  NPTS,  1)  ; 

THIS  SUBROUTINE  PERFORMS  A  FOURIER  TRANSFORM  ON  THE  THE  IN 
ARRAY  PRESS2,  WITH  NPTS  HAVING  A  VALUE  OF  512  OR  1024. 


SUBROUTINE  CALSELCTPRESS,  TPTIME,  NPTS,  CSEL) 

*-  DECLARE  SUBROUTINE  PARAMETER  INPUT/OUTPUT  VARIABLES. 

REAL  TPRESS(504),  TPT1ME<504),  CSEL 

INTEGER  NPTS 

•-  DECLARE  SUBROUTINE  DEPENDANT  VARIABLES. 

REAL  PRESSC2048) ,  PTIMEI2048) 

REAL  PRESS2(2048),  PTIME2(2048),  MPRESS 

REAL  LCE,  GF,  CF,  CF1 ,  CF2,  CF3 

INTEGER  ICNT,  MAXINO,  SCOUNT,  SIND,  EIND,  ETIME2,  STIME2,  TCNT1 , 

1  TCNT2,  TCNT3 

COMPLEX  IP(2048) 

*•  ASSIGN  ARRAY  TO  SIZE  1024. 

DO  3,  I  *  1.NPTS 

PRESS(I)  *  TPRESS(I) 

PTIME(I)  *  TPTIME! I) 

3  CONTINUE 

*•  PAD  WITH  0.0. 

DO  4,  I  «  NPTS+1 ,  2048 
PRESSU)  «  0.0 
PTIME(I)  *  0.0 

4  CONTINUE 

*•  INITIALIZE  VARIABLES. 

MPRESS  s  PRESS! 1) 

MAXIND  *  0 

SCOUNT  *  0 


*•  IF  THE  ARRAY  DOESN'T  START  WITH  A  VALUE  OF  ZERO  ADD  ONE. 

IF  ((PRESS(I)  .HE.  0.0))  THEN 
NPTS  ■  NPTS  ♦  1 
DO  5,  ICNT  *  NPTS,  2,  -1 

PRESS(ICNT)  *  PRESSO CNT  ■  1) 

PTIMEOCNT)  *  PTIMEOCNT  -  1) 

S  CONTINUE 

PRESSO)  *0.0 
PTIME(I)  *  PTIME<2)  •  0.5 
END  IF 

*-  IF  LAST  ELEMENT  OF  THE  ARRAY  ISN'T  ZERO  THEN  ADO  ONE. 

IF  ((PRESS(NPTS)  .ME.  0.0))  THEN 
NPTS  ■  NPTS  ♦  1 
PRESS(NPTS)  *  0.0 

PTIME(NPTS)  *  PT1N£(NPTS  •  1)  ♦  0.5 
END  IF 

*•  TRAVERSE  PRESSURE  ARRAY  FINDING  MAX  PRESSURE  AND  REMOVING  SHOCKS. 
DO  10,  ICNT  *  2,  NPTS 

*•  IF  A  SHOCK  IS  FOUND  INCREMENT  SHOCK  COUNTER  BY  ONE. 

IF  (PTIMEOCNT  •  1)  ,EQ.  PTIMEOCNT)  ♦  (SCOUNT  *  0.5)) 

1  SCOUNT  »  SCOUNT  ♦  1 

*•  INCREASE  TIME  ARRAY  BY  A  FACTOR  OF  .5  FOR  EACH  SHOCK  FOUND. 

PTIMEOCNT)  »  PTIMEOCNT)  ♦  (SCOUNT  •  0.5) 

*•  FIND  MAX  PRESSURE. 

IF  (PRESSC I CNT)  .GT.  MPRESS)  THEN 
MPRESS  *  PRESSO  CNT) 

MAX I NO  *  ICNT 
END  IF 

«•  END  LOOP. 

10  CONTINUE 

*•  CALCULATE  THE  START  ANO  END  INDICES  FOR  THE  SEC0UND  TIME  ARRAY. 
SINO  *  !NT((PT!ME(MAXIND)  -  PTIME(D)  /  0.5)  ♦  2 
EINO  *  INT( (PTIME(NPTS)  -  PT I ME ( MAX  I ND ) )  /  0.5)  *  (2  *  SIND) 

IF  (SINO. LT.1. OR. EINO. GT. 2048)  THEN 
CSEL  *  -1.0 
RETURN 
ENOIF 

PTIME2(SIND)  *  PTIME(MAXINO) 

PRESS2(SINO)  *  PRESS(MAXIND) 

*-  TRAVERSE  TIME  ARRAY  STARTING  FROM  THE  MAX  PRESS  TO  THE  LAST  ELEMEN 
DO  20,  ICNT  =  (SIND  +  1),  EIND 

*•  INCREMENT  TIME  FROM  MAX  PRESS  IN  0.5  SECOUND  INCREMENTS. 

PTIME20CNT)  *  PTIME(MAXINO)  ♦  ((ICNT  •  SIND)  *  0.5) 


END  LOOP. 


CONTINUE 


TRAVERSE  TIHE  ARRAY  STARTING  FROM  MAX  PRESS  DOWN  TO  FIRST  ELEMENT . 
DO  30,  ICNT  «  (SINO  •  1),  1,  -1 

DECREMENT  TIME  FROM  MAX  PRESS  IN  0.5  SECOUND  INCREMENTS. 

PT1ME2( ICNT)  *  PTIME(MAXINO)  -  ((SIND  -  ICNT)  *  0.5) 

ENO  LOOP. 

CONTINUE 

STIME2  ■  1 
ET1ME2  «  EIND 

FIND  THE  ELEMENT  IN  PTIME2  THAT  IS  GREATER  THAN  PTIME'  ). 

IF  (PTIME2(STIM£2)  .LT.  PTIME(D)  then 
STIME2  *  STIME2  ♦  1 
GOTO  40 
ENO  IF 

FIND  THE  ELEMENT  IN  PTIME2  THAT  IS  LESS  THAN  PTIME(NPTS). 

IF  (PTIME2(ETIME2)  .GT.  PTIME(NPTS))  THEN 
ETIME2  *  ETIME2  •  1 
GOTO  50 
END  IF 

TCNT1  «  STIME2 
TCNT3  *  2 

TRAVERSE  TIME  AND  PRESSURE  ARRAY  INTERPOLATING  PRESS  FOR  DELTA  T. 
IF  (TCNT1  .LE.  ETIME2)  THEN 

IF  THE  PRESENT  ARRAY  ELEMENT  IS  THE  MAX  PRESSURE  THEN  SKIP  IT. 
IF  (TCNTl  .EQ.  SINO)  THEN 
TCNT2  «  MAX I NO 
TCNT3  «  MAX I NO  ♦  1 
TCNTl  *  TCNTl  ♦  1 
ENO  IF 

FIND  AN  ELEMENT  OF  PTIME  THAT  IS  LARGER  THAN  PTIME2. 

IF  (PTIME(TCNT3)  .LT.  PT!ME2(TCNT1>)  THEN 
TCNT3  ■  TCNT3  ♦  1 
ENO  IF 

TCNT2  *  TCNT3  -  1 

INTERPOLATE  A  VALUE  FOR  THE  PRESS  FOR  PTIME2(TCNT1 ) . 
PRESS2(TCNT1)  «  (((PRESS(TCNT3)  •  PRESS(TCNT2) )  /  (PTIME 

1  (TCNT3)  •  PT!ME(TCNT2) ) )  *  (PTIME2(TCNT1 )  • 

2  PTIM£(TCNT2 ) ) )  ♦  PRESS(TCNT2) 

MOVE  TO  THE  NEXT  ELEMENT  OF  PTIME2. 

TCNTl  a  TCNTl  ♦  1 


GOTO  60 
END  IF 

START  PRESS2  ANO  TIME2  ARRAYS  AT  THE  FIRST  ELEMENT 
DO  SO,  ICNT  «  STIME2,  ET1ME2 

PRESS2C ICNT  -  (STJME2  •  1))  *  PRESS20CNT) 
PTIM£2( ICNT  •  (STIME2  •  1})  x  PRESS2C ICNT) 
CONTINUE 

NPTS  ■  (ETIME2  •  STIME2)  ♦  1 

IF  (NPTS. GT. 2048)  THEN 
CSEL  «  *1.0 
RETURN 
ENOIF 

PAD  THE  ARRAY  UITH  ZERO'S 
DO  90,  ICNT  *  NPTS+1,  2048 
PRESS2C ICNT)  -  0.0 
CONTINUE 

DO  100,  ICNT  *  1,  2048 
PTIME2CICNT)  «  0.0 
0  CONTINUE 

IF  (NPTS  .LE.  512)  NPTS  *  512 
IF  (NPTS  .GT.  512)  NPTS  *  1024 
IF  (NPTS  .GT.  1024)  NPTS  «  2048 

00  THE  FFT. 

CALL  FFT(PRESS2,  PTIME2,  NPTS,  NPTS,  NPTS,  1) 

COMPUTE  THE  C  WEIGHTED  SOUND  EXPOSURE  LEVEL. 

LCE  *  0.0 
T  «  NPTS  *  0.0005 
I  *  NPTS 
NPTS  -  NPTS  /  2 

DO  102  ICNT  «  1,1 

IP(ICNT)  «  CMPLX(PRESSZ( ICNT) ,PTIME2( ICNT)) 

2  CONTINUE 

DO  105  ICNT  *  1.NPTS 

IP(ICNT)  *  IP( ICNT+1 )  •  (0.5/1) 

PRESS(ICNT)  *  ICNT/0.5 
105  CONTINUE 

00  110,  ICNT  x  1,  NPTS 

GF  x  REAL((2/T)  *  IP(ICNT)  *  CONJG( IP( ICNT)) ) 

IF  (GF  .NE.  0.0)  GF  X  10  *  LOG10(GF/0. 00002**2) 
CF1  =  2.242881E16  »  PRESS(!CNT)**4 
CF2  x  PRESS( I CNT )**2  ♦  20.598997**2 
CF3  x  (PRESS( ICNT)**2  +  12194.22**2) 

CF  x  CF1  /  ((CF2  *  CF3)**2) 

IF  (CF  .NE.  0.0)  CF  *  10  *  LOGIO(CF) 


IF  ((CF+GF)  .ME.  0.0)  LCE  *  LCE  ♦  10  **((GF  +CF)  /  10.) 
110  COMT1NUE 

•-  CONVERT  THE  OUTPUT  INTO  OB. 

IF  (LCE  .HE.  0.0)  THEN 

CSEL  *  10  *  ALOCIO(LCE) 

END  IF 

*-  END  SUBROUTINE. 

RETURN 

END 


C  SUBROUTINE:  PRTSNG 
C  PROGRAMMER:  PHILIP  J.  DAY 
C  XONTECH  INC. 

C  BBN  LABORATORIES 

C  DATE:  APRIL  15,  1987 

C 

C  PURPOSE:  TO  OUTPUT  THE  BOOM  SIGNATURE  USED  TO  CALCULATE 

C  FOCAL'  OVERPRESSURES  AT  THE  GROUND. 

C 

C 

SUBROUTINE  PRTSNG(XXT,PPT,NPTS,CC) 

REAL  XXT ( 504 ) , PPT (504 ) 

INTEGER  NPTS 

COMMON  /RAYOUT/  SSIGMA, SPHIO, SXK<3> ,OPG, CSEL 

COMMON  /STATS/  STATFG,  BOOMFG,  MACHFG,  CONTFG,  BOOMVL, 

*  MACHVL ,  CONTVL(5,20),  CONTYP(5>,  VIDTH,  FFT, 

*  SI  GNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 

LOGICAL  LMFG,  LMCFL1 ,  LMCFLO,  PLYFG,  MRFG,  PERFG 
LOGICAL  STATFG,  MACHFG,  BOOMFG,  CONTFG 
LOGICAL  RAYTRC,  SIGNAT,  FFT.  SCRPAO,  SCRPSF,  SCRALL 
LOGICAL  GPCPFL ,  GPCPMH,  GPCPBM,  GPCPCN,  RAY  I NX 

IF  (.NOT. SI  GNAT)  RETURN 

TFACT  «  1000./CC 

VRITE(20,2000)  SSIGMA, SPHIO 
VRITE(20,2001) 

DO  100  I  ■  1 , NPTS 

UR  I TE ( 20 , 2002 )  XXT< I )*TFACT, PPT(I )/47.85 
100  CONTINUE 

2000  '  FORMAT! 1 1  TO  *\F12.3,'  PHIO  *',F8.3) 

2001  FORMATC  ••***»**•  PRESSURE  SIGNATURE  •*•*•****’ ,//,6X, 

*  'TIME  (MS)', 9X, 'PRESSURE  (PSF)*,/) 

2002  F0RMAT(4X, F12.3.8X, F10.4) 

RETURN 

END 


•M*************************************-******************************** 


SUBROUTINE  RBRAYS 


*-  MOOULE  NAME  :  RBRAYS 
*-  MOOULE  TYPE  :  SUBROUTINE 

•-  PROGRAMMER  :  THOMAS  REILLY 
*•  DATE  :  APRIL  20,  1987 

••  REVISIONS  : 

*•  DESCRIPTION  : 

*-  THIS  SUBROUTINE  WAS  DESIGNED  TO  READ  IN  THE  RAYS  FROM 

*•  FILE,  SORT  THE  RAYS  ON  THE  PHI  ANGLE  AND  THEN  REMOVE  THE  BA 

*-  RAYS.  ONCE  THIS  IS  DONE  THE  RAYS  ARE  WRITTEN  BACK  INTO  THE 

•-  SEQUENTIAL  ACCESS  FILE. 

*•  MOOULE  I/O  :  NONE. 


FILE  I/O  : 


•-  ONE  SEQUENTIAL  ACCESS  FILE  NAME  {?). 

*. 

VARIABLE  DICTIONARY  ; 


TARR  •  REAL! 13, 200)  :  ARRAY  THE  RAYS  ARE  SORTED  IN. 

RECNT  •  INTEGER  :  NUMBER  OF  RECORDS  IN  TARR. 

RFLAC  -  INTEGER  :  FLAG  FOR  WHAT  TYPE  OF  RAY  IT  IS. 


SUBROUTINE  RBRAYS 
COMMON  /CARL/  BOMFCT 

COMMON  /RAYOUT/  TTO,  TPHIO,  TXKC3),  TOPG,  CSEL 

INTEGER  RECNT,  K,  RFLAG 
REAL  TARR(13,500) 


REUIN0(12) 

RECNT  s  1 

*-  READ  INFORMATION  FROM  THE  FILE  INTO  TARR. 

10  CONTINUE 

READ! 1 2 ,  15,  EN0*100)  RFLAG,  (TARR(K, RECNT),  <=2, 12) 
TARR(1 , RECNT)  *  RFLAG 


TARR(10, RECNT)  *  TARR(10, RECNT)  /  47.85 
TARR(13, RECNT)  *  0.0 
RECNT  «  RECNT  ♦  1 
IF  (RECNT. 0T. 500)  THEN 

WR1TE(6,*)  '  MORE  THEN  500  CAUSTIC  RAYS  IN  RBRAYS  • 
GOTO  100 
END  IF 
GOTO  10 

15  FORMAT  (I2,1X,F10.2,3F8.0,F9.3(F10.2,2F8.0,F11.412F10.4) 

*•  SORT  THE  ARRAY  TARR  ON  PHI  ANGLE. 

100  CONTINUE 

RECNT  *  RECNT  •  1 

IF  ((RECNT  .LE.  1)  .ANO.  (TARR(10,1)  .EQ.  0.0))  RETURN 
IF  (RECNT  .LT.  3)  GOTO  700 
CALL  SORT (RECNT,  TARR,  6) 


•-  SEARCH  ARRAY  FROM  THE  BEGINNING  LOOKING  FOR  BAD  RAYS. 

DO  200,  I«  1,  (RECNT-2) 

IF  (((TARR(10, I )  .LT.  TARR( 10, 1*1 ))  .AND.  (TARR( 10, 1+1 ) 

1  .GT.  TARR(  10, 1*2) ) )  .OR.  ((TARR(10,I)  .GT.  TARR(10, 1  +  1)) 

2  .AND.  (TARROO, 1*1 )  .LT.  TARR(10, 1*2))))  THEN 

AVRG  *  (TARR(IO.I)  ♦  TARR(10,I+1)  +  TARR(10, I+2))/3.0 
0IF1  «  ABS(TARR(10,I)  •  AVRG) 

0IF2  «  ABS(TARR(10, 1+1 )  *  AVRG) 

0IF3  «  ABS(TARR(10, 1+2)  •  AVRG) 

XBAO  *  MAX(DI FI ,DIF2) 

XBAO  «  MAX(0 I F3,X8AD) 

IF  (XBAD  .EQ.  DIF1)  IBAO  *  1 

IF  (XBAD  .EQ.  DIF2)  IBAD  =  2 

IF  (XBAD  .EQ.  DIF3)  IBAO  x  3 

IF  (IBAD  .EQ.  2)  THEN 

DEVI  *  ABS(TARR(10, I )  •  TARR(10,I*1)) 

DEV2  *  ABS(TARR( 10, 1*1 )  •  TARR( 10, 1+2) ) 

ROEV  *  MAX(0EV1 ,D£V2) 

IF  (RDEV  .EQ.  0EV1 )  IBCNT  *  0 
IF  (ROEV  .EQ.  DEV2)  IBCNT  ■  2 
DPHI  *  ABS(TARR(6, I+IBCNT)  •  TARR(6,I*1)) 

DSEC  ■  RDEV  /  DPMI 
IF  (DSEC  .GE.  15.0)  THEN 

TARR(13, 1*1 )  x  TARR(13, 1*1 )  ♦  1.0 
END  IF 
ENOIF 

END  IF 
200  CONTINUE 

DO  300  I  *  RECNT,  3,  -1 

IF  ( ( (TARR(10, 1 )  .LT.  TARR( 10, 1 • 1 ) )  .AND.  (TARR(  10,1-1) 

1  .GT.  T ARR( 10,1-2)))  .OR.  ((TARR(10,I)  .GT.  TARR ( 10,1-1)) 

2  .AND.  (TARRC 10,1-1)  .LT.  TARR( 10,1-2))))  THEN 

AVRG  x  (TARR{1 0, I )  ♦  TARR( 10, 1  - 1 )  ♦  TARR (1 0 , 1 ■ 2) )/3 
0 1 F 1  X  ABS( TARR ( 1 0,1)  •  AVRG) 

DIF2  x  ABS(TARR(10,I-1)  •  AVRG) 

0IF3  x  ABS(TARR(10,I-2)  •  AVRG) 


X8AD  *  MAX(DIF1,01F2) 

XBAD  *  MAX(X8AD,D1F3) 

IF  (XBAD  .EO.  DIF1)  IBAD  *  1 

IF  (XBAD  .EO.  0IF2)  IBAD  *  2 

IF  (XBAD  .EO.  DIF3)  IBAD  *  3 

IF  (IBAD  .EO.  2)  THEM 

DEVI  *  ABS(TARR(10, I )  -  TARR( 10, I • 1 ) ) 

DEV2  *  ABS(TARR(10, 1  - 1 )  •  TARR(10, 1 -2)) 

RDEV  *  MAX(DEV1 ,DEV2) 

IF  (RDEV  .£0.  DEVI)  ISCNT  «  0 
IF  (RDEV  .£0.  DEV2)  1BCNT  *  2 
DPMI  «  A8S(TARR(6,I-I8CNT)  •  TARR(6,I-1)) 

DSEC  *  ROEV  /  DPH1 
IF  (OSEC  .CE.  15.0)  THEN 

TARR(13, 1 -1 )  *  TARR(13, 1*1)  ♦  1.0 
END  IF 
ENOIF 
END  IF 

300  CONTINUE 

700  PMAX  *  -999999.9 

DO  400,  1*1 ,RECNT 

IF  (TARR( 13, I )  .IT.  2.0)  THEN 
IF  (TARR(10, I )  .GT.  PMAX)  THEN 
I MAX  *  1 

PMAX  *  TARR(10,I) 

ENOIF 

*-  WRITE  OUT  TO  FILE 

TTO  *  TARR(7,I) 

TPHIO  *  TARR(6, I ) 

TXX( 1 )  *  TARR(8, I ) 

TXK(2)  *  TARR(9, I ) 

TOPG  *  TARR(10, I )  *  47.85 
CSEL  •  TARR(1 1,1) 

600  CALL  ST0RE(21,. FALSE., .FALSE.,. FALSE. ,IREC) 

ENOIF 

400  CONTINUE 

*-  WRITE  RECORD  IMAX  OUT  TO  FILE  10. 

TARR(10, I MAX)  *  TARR(10, IMAX)  *  47.85 

WRITE(8,500)  (TARR(K,IMAX),X*2,5>,  (TARR(X, IMAX) , 

1  K*7,9),  TARR(6, IMAX) ,  TARR(10, IMAX), 

2  TARR( 1 1 , IMAX) ,  BOMFCT 

500  FORMAT(F8.2,3F8.0,F8.2,2F8.0,F8.3,F10.4,F10.4,F10.4) 

END 


SUBROUTINE  sort 


*-  MODULE  NAME  :  SORT 
*•  MOOULE  TYPE  :  SUBROUTINE 


*•  PROGRAMMER  :  THOMAS  REILLY 
*-  DATE  :  DECEMBER  1,  1986 

*-  DESCRIPTION  : 

*•  THIS  SUBROUTINE  IS  DESIGNED  TO  SORT  AN  INPUTED  ARRAY 

*-  USEING  A  HEAP  SORT  METHOD  ON  A  SEPECIFIED  SORT  FIELD. 


* 


VARIABLE  DICTIONARY  : 


TEMPAR  -  ARRAY  OF  RAY'S  TO  8E  SORTED  ON  TERMINATION  TIME. 

TRAY  •  TEMPORARY  VARIABLE  TO  HOLD  AN  ELEMENT  OF  THE  RAY  DATA  UH 
IT  IS  BEING  SU1TCHE0  WITH  ANOTHER  ELEMENT. 

NREC  •  NUMBER  OF  RECORDS  IN  THE  SEGMENT  TO  BE  SORTED. 

SREC  -  STARTING  RECORD  OF  THE  SEGMENT. 

OFFSET  -  OFF  SET  BETWEEN  THE  ARRAY  AND  STARTING  RECORD  OF  THE  SEG 
I ,J,K,L  •  COUNTERS  USED  TO  MINIPULATE  THE  ARRAY. 

IR  •  COUNTER  USED  TO  MINIPULATE  THE  RAY  ARRAY. 


*•  CALLING  MOOULE  : 


SCRHFL  •  SUBROUTINE  THAT  CREATES  THE  SCRCHPAD  FILE. 


*•  CALLED  MOOULE  :  NONE. 


SUBROUT I NE  SORT ( NPTS , TEMPAR , SRTFLD ) 


INTEGER  NPTS,  I,  J,  K,  L,  ARRL,  SRTFLD 

PARAMETER  (ARRL  *  13) 

REAL  TRAY (ARRL) 

REAL  TEMP AR( ARRL , 500) 

*-  SET  UP  INITIALIZATION  FOR  HEAPSORT. 

L  *  NPTS  /  2  ♦  1 
IR  *  NPTS 

HEAP  CREATION  PHASE. 

30  CONTINUE 

IF  <L  .GT.  1)  THEN  ; 

L  =  L  -  1 


INITIALIZE  RRA  TO  ELEMENT  RA(L)  IN  THE  RAY  ARRAY. 


00  32,  1C  *  1,  ARRl 

TRAYOO  «  TEMPARCK, L) 

CONTINUE 

■USE 

PLACE  TOP  OF  HEAP  AT  THE  END  OF  THE  ARRAY. 

OO  34,  K  *  1 ,ARRL 

TRAY  ( K )  *  TEMPARCIC,  IR> 

TEMPARCK,  IR)  -  TEMPARCIC, 1) 

CONTINUE 
IR  -  IR  •  1 

PLACE  SMALLEST  ELEMENT  AT  THE  BEGINING  OF  THE  ARRAY. 

IF  (IR  ,EQ.  1)  THEN 
DO  36,  K  *1 , ARRL 

TEMPARCIC,  1)  *  TRAYCK) 

CONTINUE 

EXIT  LOOP  ANO  WRITE  ARRAY  BACK  INTO  THE  RAY  FILE. 

GO  TO  100 
END  IF 
END  IF 
I  *  L 
J  *  L  ♦  L 

SET  UP  TO  SHIFT  DOWN  ELMENT  RRA  TO  ITS  PROPER  LEVEL 
IF  CJ  .LE.  IR)  THEN 
IF  CJ  .IT.  IR)  THEN 

COMPARE  THE  RAY  TERMINATION  TIMES. 

IF  CTEMPARCSRTFLD.J)  .LT.  TEMPARCSRTFLD,U+1))>  J  =  J  *  1 
END  IF 

COMPARE  THE  RAY  TERMINATION  TIMES. 

IF  CTRAYCSRTFLD)  .LT.  TEMPAR C SRTFLD , J ) )  THEN 
00  72,  K*1 ,ARRL 

TEMPARCK,!)  *  TEMPARCK, J) 

CONTINUE 
I  *  J 
J  *  J  ♦  J 
ELSE 

THIS  IS  RRA'S  LEVEL.  SET  J  TO  TERMINATE  SHIFT  DOWN 
J  *  IR  ♦  1 
END  IF 

LOOP  WHILE  J  LESS  THAN  OR  EQUAL  TO  IR. 

GO  TO  70 
END  IF 

PUT  RRA  INTO  ITS  SLOT. 

OO  74,  K*1,ARRL 

TEMPARCK, I)  =  TRAYCK) 

CONTINUE 


*-  LOOP  UNTIL  ARRAY  IS  SORTED. 
SO  TO  30 

100  CONTINUE 
RETURN 
END 


**************************** *****************************«***»*«a»***#*»* 


SUBROUTINE  LSQUAR 


MOOULE  NAME 

:  LSQUAR 

MOOULE  TYPE 

:  SUBROUTINE 

PROGRAMMER 

:  THOMAS  REILLY 

DATE 

:  MAY  7,  1987 

DESCRIPTION 

THIS  SUBROUTINE  IS  DESIGNED  TO  ACCEPT  A  VELOCITY 

VECTOR  WHICH  IT  THEN  WEIGHTS  AND  COMPUTS  A  LEAST  SQUARE 
APPROXIMATION  FOR  A  POLYNOMIAL  OF  N  DEGREES  WITH  NPTS. 


SUBROUTINE  LSQUAR(TIME) 


COMMON  /SPLINE/  NPTS,S(100,3) ,A(100,3) , B( 100,3) ,C(100,3) , 

1  0(100, 3) 

PARAMETER  (N  *  2) 


DIMENSION  ACCVEC(100,3),  TIME(IOO),  T(6),  ACWGHT(6,3) 

DIMENSION  E(20,21 ) 

INTEGER  NPTS,  DET 


IF  (NPTS  .LT.  3)  RETURN 

*-  READ  ACCELARTION  VECTOR  INTO  ACCVEC. 

00  5  I  *  1,  100 
DO  5  J  =  1,3 

ACCVEC( I ,  J)  a  C(I,J) 

5  CONTINUE 

DO  10  I  *  1,3 
A(1 , I )  *  0.0 
8(1  .1)  *  0.0 
0(1,1)  a  0.0 
10  CONTINUE 

*•  MOVE  THE  WEIGHT  WINDOW  ONE  ELEMENT  AT  A  TIME. 

DO  1000  I  *  2, NPTS 

*•  IF  ITS  THE  FIRST  OR  LAST  ELEMENT  WEIGHT  IT  1  2  1. 

IF  ((I  .EQ.  2)  .OR.  (1  .E 0.  NPTS))  THEN 
IF  (I  .EQ.  2)  THEN 
K  =  1 
L  a  U 


ELSE 


K  *  HP TS  ■  2 
L  «  NPTS 
END  IF 

IF  ((j  .EO.  1C)  .08.  (J  .EQ.  L)>  THEN 

U  a  1 

ELSE 
U  *  2 
END  IF 

DO  50  J2  «  1,3 

50  ACUGHTO ,  J2)  »  ACCVECCIC,  J2) 

T{1)  »  TIME(K)  ■  T1ME(K*1 ) 

DO  60  J  ■  2,3 
DO  70  J2  «  1,3 

ACUGHTCJ.J2)  *  ACCVECCK+1.J2) 

TO  CONTINUE 

T(  J)  «  0.0 

60  CONTINUE 

DO  SO  J2  »  1,3 

80  ACWGHT(4,J2)  »  ACCVECCIC+2, J2) 

T(4)  ■  T1HEIK+2)  •  TIMEOC+1) 

100  CONTINUE 

CAPN  *  4 

*■  IF  ITS  NOT  THE  FIRST  OR  LAST  ELEMENT  WEIGHT  IT  1  2  2  1. 

ELSE 

K  «  I  •  2 

IF  <( J  .EG.  0-2))  .OR.  (J  .EO.  0*1)))  THEN 
U  »  1 
ELSE 
W  a  2 
ENOIF 

DO  150  J2  •  1,3 

150  ACWGHTO  ,  J2)  *  ACCVECOC,  J2) 

T(1 )  «  TIMEOC)  •  TIME(K+2) 

DO  160  J  »  2,3 
00  170  J2  »  1,3 

170  ACWGHT(J,J2)  a  ACCVEC(K*1,J2) 

T(J)  a  TIME(K+1 )  •  TIME(K+2> 

160  CONTINUE 

00  180  J  «  4,5 
DO  190  J2  a  1,J 

ACUGHT(J,  J2)  «  ACCVECCK+2, J2) 

190  CONTINUE 

T(J)  a  0.0 

180  CONTINUE 

DO  195  J2  »  1,3 

195  ACWGHTC6, J2)  *  ACCVECCK+3, J2) 

T(6)  *  TINEOC+3)  -  TIMEOC+2) 

200  CONTINUE 

CAPN  a  6 
ENOIF 


DO  900  K1  a  1,3 


OET  *  2 
NP1  «  N  ♦  1 
DO  300  11*1,  NP1 
EC  1 1 ,N+2)  «  0.0 
OO  300  J  ■  1,11 
E(I1,J)  »  0. 

300  CONTINUE 

00  500  K  «  1,  CAPN 

PI  -  1.0 

00  500  II  *  1 ,NP1 
P2  »  1.0 
00  400  J  *  1,11 

EC  1 1 , J >  «  E(II.J)  ♦  PI  *  P2 
P2  *  P2  *  TOO 
400  CONTINUE 

EC  II  ,N*2)  -  EC  1 1  ,N+2)  ♦  PI  *  ACUGHT (K,K1 ) 
PI  »  PI  *  TOO 
500  CONTINUE 

00  600  II  *  1,  NP1 
OO  600  J  *  1,  II 
EC J ,11)  *  EC11.J) 

600  CONTINUE 

CALL  GAUSJR(N+1 ,  OET,  E,  DELTA) 

ACI ,K1)  *  E(3,N*2) 

3(1 ,K1)  -  E(2,N+2) 

CC I ,K1 )  «  EC 1 ,N*2) 


900  CONTINUE 
1000  CONTINUE 

RETURN 

END 


»*»*»»**«*»»•*»*»»•*»» 


>***»**•*»•*»»•»»*•••*»***•»••*»*»*••*»**»«*»»**»**»*•»*»*»•»•«*»»»•»»•* 

SUBROUTINE  GAUSJR  «•*••*»'*******«*”****** 


SUBROUTINE  FOR  GAUSS- JORDAN  REDUCTION  AND  DETERMINANT  EBALUATIO 
N  EQUALS  THE  NUMBER  OF  EQUATIONS.  M  EQUALS  N,  AND  DET  IS  1  IF 
ONLY  THE  DETERMINANT  IS  TO  BE  RETURNED.  OTHERWISE  THE  DET  IS  2 
ANO  H  »  N  ♦  1. 


SUBROUTINE  GAUSJRtN,  OET,  E,  DELTA) 


INTEGER  OET 
DIMENSION  E(20,21) 


M  »  N  ♦  1 

GOTO  <3, 6), DET 


3  M  >  N 

•-  INITIALIZE  THE  DETERMINANT. 

6  DELTA  ■  1 

DO  12  K  *  1,N 

DELTA  *  DELTA  *  E(K.K) 

KP1  *  K  *  1 
DO  9  J  ■  KP1.M 

EOC.J)  «  EOC.J)  /  E(K,K) 

9  CONTINUE 

IF  (KP1  .GT.  N)  GOTO  13 
DO  12  I  *  KP 1,N 
DO  12  J  »  KP1 ,M 

E(I,J)  «  Ed, J)  -  E(I ,K)  •  EOC.J) 

12  CONTINUE 

13  IF  (DET  .EQ.  1)  GOTO  18 
NM1  »  N  -  1 

DO  15  IND  *  1,  NM1 
K  *  N  ♦  1  -  INO 
KM1  *  K  -  1 

DO  15  I  »  1,  KM1 

Ed,M)  *  Ed  ,M)  -  Ed  ,K)  *  EOC.M) 

15  CONTINUE 

18  RETURN 

END 

SUBROUTINE  STOREC(TI TLE , GPCPFL ,  GPCPMH,  GPCPBM) 


THIS  SUBROUTINE  IS  OESIGNED  TO  STORE  NEEDED  VARIABLES  IN 
A  TEMPORARY  FILE  SO  THE  PLOT  I NG/RAYTRAC I NG  CAN  ?E  RUN  AS 


A  TWO  STEP  PROCESS. 


COMMON  /CHRTA8S/  ARCRFT,  MSSNS,  SITES,  TAILNM 
COMMON  /INTTA8S/  ENOATE,  ENTIME,  STDATE,  STTIME,  NUMREP 

COMMON  /STATS/  STATFG,  BOCMFG,  MACHFG,  CONTFG,  BOOMVL, 

1  MACH VI,  CONTVL,  CONTYP,  WIDTH,  FFT, 

2  SI GNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 

INTEGER  ENDATE(5,10),  ENTIME(3, 10),  STDATE(5,10) 

INTEGER  STTIME<5, 10) ,  CONTYP(5),  NUMREP 

REAL  CONTVL(5,20),  BOOMVL,  MACHVL ,  WIDTH 

LOGICAL  STATFG,  BOCMFG,  MACHFG,  CONTFG,  SIGNAT,  RAYTRC, 

1  SCRPAD,  SCRPSF,  SCRALL,  GPCPFL,  FFT,  GPCPMH,  GPCPBM 

CHARACTER*70  TITLE 
CHARACTERS  ARCRFT<5,10) 

CHARACTER*^  MSSNS(5,10) 

CHARACTERS  0  SITES(5,20) 

CHARACTERS  TAILNM<5,10) 

OPEN ( 76 , F I LE» ' HOLD VAR ' , STATUS* ' UNKNOWN ' ) 

WRITE(76, FMT*' (A) 1 )  TITLE 
DO  10  I  *  1,  5 

WR1TE(76, FMT= 1 (A) 1 )  (ARCRFT < I , J) , J=1 , 10) 

WRITE(76, FMT*1 (A) 1 )  (MSSNS( I , 4) , J*1 , 10) 

WRITE(76, FMT»‘ (A) ' )  (SITES( I ,4), J»1 ,20) 

WRITE (76, FMT* 1 (A) 1 )  (TAILNM( I , J), 4*1 , 10) 

WRITE(76, FMT*1  (18) ' )  (ENTIMEd  ,4),4*1 , 10) 

WRITE (76,  FMT*'  (18) ' )  (ENDATEd  ,4), 4*1 ,10) 

WR1TE{76,FMT*'  ( 18) 1 )  (STTIMEd  ,4),4*1 , 10) 

WR1TE(76, FMT*' (18) 1 )  ( STDATE ( I ,  4), 4=1 , 10) 

WRITE(76, FMT*1 ( 18) ' )  CONTYP(I) 

WRITE(76, FMT*1 (F20.4) 1 )  (CONTVL( I , J), J=1 ,20) 

CONTINUE 

. WRITE(76, FMT*' (5L1 ) ' )  STATFG,  BOOMFG,  MACHFG,  CONTFG,  FFT 
WRITE(76, FMT*' (6L1 ) ' )  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL, 
1  GPCPFL 

WRITE (76, FMT*' (3F20.4) 1 )  BOOMVL,  MACHVL,  WIDTH 
WRITE (76, FMT*' (2L1 , 18) 1 )  GPCPMH,  GPCPBM,  NUMREP 
CL0SE(76) 


RETURN 


!****• 


E  - 


i 


tt***************************************************************** 

SUBROUTINE  SCRPAO  ••*«•*****•*••••** 
*****************«««****«*•«««•#*«**«**»**«************«*«******** 

•  HOOULE  NAME  :  SCRPAO 
-  HOOULE  TYPE  :  SUBROUTINE 

•  PROGRAMMER  :  HARRY  SEIOMAN 

•  DATE  :  DECEMBER  1986 

■  REVISIONS  :  MARCH  1987,  UPDATED  TO  BE  CONSISTENT  UITH  BOOMAP2. 

•  DESCRIPTION  : 

THE  PURPOSE  OP  THIS  SUBROUTINE  IS  TO  READ  DATA  FROM  TH 
SCRCHPAD  FILE  TO  PLOT  CONTOURS.  IT  ALSO  CALCULATES  AREA  OF 
CONTOUR  LEVELS  AND  CALLS  THE  APPROPRIATE  SUBROUTINES  TO  CAL 
THE  CONTOUR  LEVELS. 

■  MOOULE  I/O  :  SCRPAO(SCRPSF) 


INPUTS  : 

SCRPSF  •  LOGICAL  :  FLAG  TRUE  IF  CONTOURS  ARE  TO  BE  IN  PSF  E 
OUTPUTS  :  NONE. 


FILE  I/O  : 


SCRCHFL  •  FILE  CONTAINING  THE  SORTED  SCRCHPAD  RAY  DATA. 


VARIABLE  DICTIONARY  : 


ACTYPE 

•  CHAR (8) 

AIRCRAFT  TYPE. 

AR 

-  REAL 

AREA  OF  THE  CONTOUR  LEVEL. 

ATI  ME 

•  REAL(IOOO) 

TIME  ASSOCIATED  WITH  A/C  X,Y 

Z  COORD  I  NAT 

AX 

•  REAL (1000) 

X  COORDINATE  ASSOCIATED 

WITH 

THE 

A/C. 

AY 

-  REAL (1000) 

Y  COORDINATE  ASSOCIATED 

WITH 

THE 

A/C. 

AZ 

•  REAL (1000) 

Z  COORDINATE  ASSOCIATED 

WITH 

THE 

A/C. 

C3LEV 

•  REAL 

CARBET  BOOM  LEVEL  USING 

CARLSON’S 

METHOD 

CONVAL 

•  REAL  C 1 0> 

10  CONTOUR  VALUES  TO  ATEMPT  TO  MAKE  3  CO 

EMACHN 

•  REAL 

ENDING  MACH  NUMBER. 

IPATH 

■  INT (1000) 

THE  PATH  TO  CONECT  THE  CONTOUR  PTS. 

IPTS 

•  I  NT (1000) 

NUMBER  OF  PTS  FROM  EACH 

TIME 

HACK 

ACCUIR 

JPTR 

•  INTEGER 

NUMBER  OF  PTS  IN  IPATH. 

MAXOP 

•  REAL 

MAXIUM  OVERPRESSURE. 

MOATE 

-  CHAR (8) 

MNAME 

-  CHAR( 16) 

MS  ITS 

•  CHAR(IO) 

NPPH 

-  INT(IOOO) 

NPTS 

•  INTEGER 

NTH 

-  INTEGER 

PRESS 

•  REAL (1000) 

RX 

*  REAL (1000) 

RY 

-  REAL (1000) 

SMACHN 

-  REAL 

TAILN 

•  CHAR (8) 

XCOOftD 

•  REAL 

XINT 

•  REAL (1000) 

Y COORD 

-  REAL 

YINT 

•  REAL (1000) 

XPLT 

-  REAL (1000) 

YPLT 

-  REAL (1000) 

ZCOORO 

•  REAL 

MISSION  DATE. 

MISSION  NAME. 

MISSION  SITE. 

UPPER  BOUND  IN  ARRAY'S  FOR  EACH  TIME  HAC 
NUMBER  OF  PTS  READ  IN  FROM  THE  FILE. 
NUMBER  OF  TIME  HACKS. 

PRESS  ASSOCIATED  WITH  RX,  RY. 

X  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 

Y  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 
STARTING  MACH  NUMBER. 

TAIL  NUMBER  OF  THE  A/C. 

X  COORDINATE  OF  THE  MAXIUM  OVERPRESSURE. 
X  COORDINATE  OF  THE  INTERPOLATED  CONTOUR 

Y  COORDINATE  OF  THE  MAXIUM  OVERPRESSURE. 

Y  COORDINATE  OF  THE  INTERPOLATED  CONTOUR 
X  COORDINATE  OF  THE  CONNECTED  PTS  TO  PLO 

Y  COORDINATE  OF  THE  CONNECTED  PTS  TO  PLO 
Z  COORDINATE  OF  THE  MAXIUM  OVERPRESSURE. 


CALLED  MOOULES  S 


CCONVL  (PRESS,  NPTS,  CONVAL,  SCRPSF);  CONVERTS  FROM  PASCALS  TO  PS 
PRESS  •  REAL (1000)  :  PRESSURE  IN  PASCALS  RETURNED  IN  DB  OR  PS 

NPTS  -  INTEGER  :  NUMBER  OF  POINTS  IN  PRESS. 

CONVAL  -  REAL(IO)  :  CONTOUR  LEVELS  TO  LOOK  FOR.  . 

SCRPSF  •  LOGICAL  :  FLAG  TRUE  IF  PRESSURE  TO  BE  IN  PSF. 


PSETUP  (AX,  AY,  AZ,  NPTS,  XTEMP,  YTEMP,  XBASE,  YBASE,  ATIME,  FTS, 
SETS  UP  THE  PLOT  PAGE  WITH  THE  FLIGHT  TRACK,  FLIGHT  INFORM 
AND  SCALES  THE  CONTOURS  AND  FLIGHT  TRACK. 

ATIME  •  REAL(IOOO)  :  TIME  ASSOCIATED  WITH  A/C  X,Y,Z  COORDINAT 

AX  -  REAL (1000)  :  X  COORDINATE  ASSOCIATED  WITH  THE  A/C. 

AY  •  REAL(IOOO)  :  Y  COORDINATE  ASSOCIATED  WITH  THE  A/C. 

AZ  •  REAL (1000)  :  Z  COORDINATE  ASSOCIATED  WITH  THE  A/C. 

NPTS  •  INTEGER  :  NUMBER  OF  PTS  READ  IN  FROM  THE  FILE. 
XTEMP  -  REAL  :  STARTING  X  COORDINATE  OF  THE  FLIGHT  TRAC 

YTEMP  •  REAL  :  STARTING  Y  COORDINATE  OF  THE  FLIGHT  TRAC 

XBASE  •  REAL  :  PLACE  FROM  WHICH  TO  BASE  THE  CONTOUR. 

Y8ASE  •  REAL  :  PLACE  FROM  WHICH  TO  BASE  THE  CONTOUR. 

ATIME  •  REAL (1000)  :  TIME  ASSOCIATED  WITH  X,Y,Z  OF  THE  A/C. 
FTS  •  REAL  :  SLOPE  OF  THE  FLIGHT  TRACK. 

SCALE  -  REAL  :  SCALE  OF  THE  FLIGHT  TRACK  AND  CONTOUR. 


FNCCNT  (PRESS(LPTR),  RX(LPTR),  RY(LPTR),  NPPH(JPLT), 

CONVAL ( I PLT ) ,  ITPTR,  XINT,  TINT,  ICNT); 

FINOS  X  ANO  Y  COORDINATES  ASSOCIATED  WITH  THE  CONTOUR  LEV 
EACH  TIME  HACK. 

PRESS  •  REAL ( 1000)  :  PRESSURE  IN  PASCALS  RETURNED  IN  DB  OR  PS 

RX  •  REAL(IOOO)  :  X  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 

RY  •  REAL (1000)  :  Y  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 


NPPH 

■  INTEGER 

CONVAL 

-  REAL 

ITPTR 

-  INTEGER 

XINT 

•  REAL (1000) 

TINT 

-  REAL (1000) 

ICNT 

•  INTEGER 

HUMBER  OF  PTS  IN  THIS  CURRENT  TIME  HACK. 
CURRENT  CONTOUR  VALUE  BEING  SEARCHED  FOR 
NUMBER  OF  PTS  FOUND  FOR  THIS  CONTOUR  LEV 
X  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 
T  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 
NUMBER  OF  PTS  FOUND  FOR  CURRENT  TIME  HAC 


CONPTS  (IPTS,  NTH,  IPATH,  JPTR);  CONNECTS  THE  PTS  THAT  ARE  RETURN 
BY  FNOCNT  TO  CREATE  A  CONTOUR. 


I  PTS 

-  INT(IOOO) 

:  NUMBER  OF  PTS  FROM  EACH  TIME  HACK  ACCU1R 

NTH 

-  INTEGER 

:  NUMBER  OF  TIME  HACKS. 

IPATH 

-  INT(IOOO) 

:  THE  PATH  TO  CONECT  THE  CONTOUR  PTS. 

JPTR 

-  INTEGER 

:  NUMBER  OF  PTS  IN  IPATH. 

PLOT IT  (XPLT, 
FTS, 

XINT 

TINT 

JPTR 

XTEMP 

YTEMP 

XBASE 

YBASE 

AR 

CONVAL  - 
FTS 

SCALE  • 
SCRPSF  • 


YPLT,  JPTR,  XTEMP,  YTEMP,  XBASE,  YBASE,  AR,  CONVAL (I 
SCALE,  SCRPSF);  PLOTS  EACH  OF  THE  THREE  CONTOUR  LEVEL 


REAL (1000) 

REAL (1000) 

INTEGER 

REAL 

REAL 

REAL 

REAL 

REAL 

REAL 

REAL 

REAL 

LOGICAL 


X  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 
Y  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 
NUMBER  OF  PTS  IN  IPATH. 

STARTING  X  COORDINATE  OF  THE  FLIGHT  TRAC 
STARTING  Y  COORDINATE  OF  THE  FLIGHT  TRAC 
PUCE  FROM  WHICH  TO  BASE  THE  CONTOUR. 
PUCE  FROM  WHICH  TO  BASE  THE  CONTOUR. 
AREA  OF  THE  CONTOUR  LEVEL. 

CURRENT  CONTOUR  VALUE  BEING  SEARCHED  FOR 
SLOPE  OF  THE  FLIGHT  TRACK. 

SCALE  OF  THE  FLIGHT  TRACK  AND  CONTOUR. 
FLAG  TRUE  IF  CONTOURS  ARE  TO  BE  IN  PSF  E 


CLSPLTO;  CREATES  A  NEW  PLOT  PAGE. 


CALLING  MODULE  : 


SUBROUTINE  SCRPAO(SCRPSF,  TEMPAR) 


DIMENSION 

DIMENSION 

DIMENSION 

DIMENSION 

DIMENSION 


ATIME(4000),  AX (4000) ,  AY(4000),  AZ(4000) 
RX(4000) ,  RY(4000) ,  PRESS(4000) ,ACTIME(4000) 
NPPH(1500),  IPTS(1500) ,  YPLT0500),  ACT(1500) 
XINT(1500),  YINT(1500),  IPATH(1500),  XPLT(ISOO) 
CONVAL(IO),  TACT0500),  TEMPAR(  1 1 , 1000) 


COMMON  /HEADER/  MNAME,  MOATE,  MSITE,  ACTYPE,  TAILN 
COMMON  /OPREC/  SMACHN,  C8LEV,  MAXOP,  XCOORD,  YCOORD,  ZCOORD, 
1  EMACHN 


CHARACTER  *8 


ACTYPE,  MOATE,  TAILN 


CHARACTER  *10  MSITE 

CHARACTER  *16  MNAME 

REAL  MAXOP,  EMACHN,  SMACHN 

LOGICAL  SCRPSF,  SMFLG,  NEWPLT 


C 

C  INITIALIZE  COUNTER  ETC. 

DATA  ITPTR, ITH/2*0/ 

C 

REUINO(32) 

10  CONTINUE 

I  *  1 

PH1 1  «  0.0 
PHI2  »  0.0 
SMFLG  *  .FALSE. 

NEWPLT  *  .TRUE. 

C  READ  THE  MISSION  INFORMATION  FROM  THE  HEADER 

READ (32,15, END=200 )  MNAME,  MOATE,  MSITE,  ACTYPE,  TAILN,  ZCOORD 
15  FORMAT  (3X.A16,  Aa,2X,  A10,  2X  ,2Aa,2X,F9.2) 

20  CONTINUE 

•-  READ  A  RECORD  FROM  THE  SCRCHPAD  FILE. 

READ(32,3201  ,ENO  «  200)  ATIMEd ),AX< I) ,AY( I  ),AZ( I ), 

1  ACT I ME ( I ) ,  RX( I ),RY< I ) , TEMP2,PRESS( I ) ,  TEMP3,  TEMP4 

3201  FORMAT(F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 

IF  (I  ,EO.  1)  THEN 
PH1 1  *  TEMP2 
PH 1 2  i  TEMP2 
ELSE 

PH1 1  «  PHI2 
PHI2  «  TEMP2 
END  IF 

*•  IF  ITS  THE  FIRST  RECORD  STORE  THE  STARTING  MACH  NUMBER. 

IF  (I  .Ed.  1)  SMACHN  *  TEMP4 

*•  CONVERT  FROM  METERS  TO  FEET. 

AX( I )  *  AX <13  /  0.3048 
AY(I)  *  AYC I >  /  0.3048 
AZ(I)  *  AZ( I )  /  0,3048 
RX(I)  *  RX(I)  /  0.3048 
RY( l )  =  RY Cl)  /  J048 

*■  IF  ITS  THE  LAST  RECORD  STORE  THE  ENOING  MACH  NUMBER. 

IF  <<ATIME<15  ,NE.  88.)  .AND.  (ATIMEd)  .HE.  99.))  THEN 
1=1*1 

IF  (I  .GT.  4000)  THEN 

PRINT  «, 'EXCEEDING  ARRAY  BOUNDS  GT  4000' 

ENOIF 

EMACHN  =  TEMP4 


SO  TO  20 
ENO  IF 

*•  REAO  THE  MAXIMUM  OVERPRESSURE  RECORD. 

READ  (32,  3202,  EN0-200)  TEMP,  TEMP2,  TEMP3,  TEMP4,  TEMPS, 

1  X COORD ,  Y COORD ,  MAXOP,  TEMP6,  C8LEV 

3202  FORMAT  (F8.2,3F8.0,F8.2,2F8.0,3F10.4> 

*-  CONVERT  FROM  METERS  TO  FEET. 

XCOORD  *  XCOORD  /  0.3048 
Y COORD  *  Y COORD  /  0.3048 
ZCOORD  *  ZCOORD  /  0.3048 

200  CONTINUE 
NPTS  *  1-1 

IF  (I  .l£.  1)  GO  TO  400 

*•  CONVERT  PRESSURE  FROM  PASCALS  TO  DB  OR  PSF. 

CALL  CCONVLC  PRESS,  NPTS, . CONVAL,  SCRPSF) 

*•  SET  UP  PLOT,  PLOT  FLIGHT  TRACK  AND  FLIGHT  TRACK  INFORMATION. 

CALL  PSETUP  (AX,  AY,  AZ,  NPTS,  XTEMP,  YTEMP,  XBASE,  YBASE,  ATIME, 
1  FTS,  SCALE) 


*•  FIND  CONTOUR  INFORMATION  FOR  UP  TO  3  CONTOURS. 

*•  find  THE  MIN  X,Y  COORO  OF  THE  RAYS  INCASE  IT  IS  A  STRAIGHT  ACCELAR 

*•  FLIGHT. 

CNTMIN  *  99999999 
DO  250,  I a  1 , NPTS 

IF  (CNTMIN  .GT.  (ABS(RX(! ))  ♦  ABS(RY(I))))  THEN 
XHOLD  *  RX(I) 

YHOLD  =  RY(I) 

CNTMIN  *  ABS(RX( I ))  ♦  ABS(RY(I)) 

ENO  IF 
250  CONTINUE 

CNTMIN  *  99999999 
DO  255  I  *  NPTS, 1 , • 1 

IF  (CNTMIN  .GT.  (ABS(RX(D)  ♦  ABS(RY(I))>)  THEN 
XHOLD 2  *  RX(  I  ) 

YHOLD2  *  RY( I ) 

CNTMIN  *  A83(RX( I ) )  ♦  ABS(RY( I ) ) 

ENO  IF 

255  CONTINUE 

ITH  *  0 

DO  256,  N-1,1000 
NPPH(I)  =  0 

256  CONTINUE 

*-  F I  NO  THE  UPPER  BOUND  OF  EACH  TIME  HACK. 

PRETIM  =  0. 

DO  300  I  =  1,  NPTS 


1F(  PRETIM  .EQ.  ATIME(l))  THEN 
NPPH(ITH)  *  NPPH(ITH)  ♦  1 
ELSE 

ITH  *  ITH  +  1 
NPPH(ITH)  *  1 
PRETIM  *  ATIME(I) 

ENOIF 
300  CONTINUE 

*-  LOOP  UNTIL  WE  GET  THREE  GOOO  PLOTS  AND  MAKE  TEN  ATTEMPTS. 
NMGOOO  *  0 
00  1000  IPLT  *  1,10 
NTH  *  1 
ITPTR  *  2 
LPTR  *  1 

*-  TRAVERSE  THROUGHT  EACH  TIME  HACK. 

00  900  JPLT  *  1,  ITH 

1F(NPPH(JPLT)  .LT.  3)  THEN 
LPTR  =  LPTR  ♦  NPPH(JPLT) 

GO  TO  900 
END  IF 

«•  FIND  PTS  FOR  THIS  CONTOUR  LEVEL. 

CALL  FNDCNT(PRESS(LPTR),RX(LPTR),RY(LPTR),NPPH(JPLT), 

1  CONVAL(IPLT), ITPTR, XINT, YINT, ICNT, ACTIME(LPTR), ACT) 

DO  41  125  *  LPTR,  NPPH(JPLT)+LPTR 
41  CONTINUE 

C 

LPTR  s  LPTR  ♦  NPPH(JPLT) 

I F <  ICNT  .LE.  1  .OR.  ICNT  .EO.  3)  GO  TO  900 

NTH  *  NTH  +  1 
IPTS(NTH)  =  ICNT 

IF  ((NMGOOO  .EO.  0)  .ANO.  (NTH  .EO.  2))  THEN 
IMHAC  *  JPLT 
XT1  »  XINT(3) 

XT2  3  XINT ( ICNT+2) 

YT1  3  YINT(3) 

YT2  *  YINT(ICNT+2) 

XT  *  (XINT(3)  ♦  XINT( ICNT+2 . ) )  /2 
YT  3  (YINT(3)  +  TINT ( ICNT+2) 5/2 
IF  ((XT  .LT.  XINT{3))  .OR.  (XT  .GT.  XI NT( ICNT+2) ) ) 

1  XT  *  (XI NT(3)  +  XINT ( ICNT+2) )/2  +  XINT(3) 

IF  ((YT  .LT.  YINT(3))  .OR.  (YT  .GT.  XINT ( I CNT+2) ) ) 

1  YT  =  (YINT(3)  ♦  Y!NT( I CN  T  +  2) )/2  ♦  Y I  NT (3 ) 

ELSE  IF  (JPLT  .EO.  IMHAC)  THEN 

I  TEMP  3  ITPTR  ■  (ICNT  •  1) 

XT1  =  XINT(ITEMP) 

XT2  =  XINT(ITPTR) 


C 

c 

c 

c 

c 

c 

c 


YT1  »  Y I MT (ITEMP) 

YT2  *  YINT (ITPTR) 

XT  «  (XINT (ITEMP)  ♦  XINT(ITPTR))  /2 
YT  »  C Y I  NT (ITEMP)  *  YINT  ( ITPTR) )/2 
IF  ((XT  .LT.  X1NT ( ITEMP) )  .OR.  (XT  .GT.  XINT( ITPTR) )) 
XT  ■  (XINT (ITEMP)  ♦  XlNT(ITPTR))/2  ♦  XINT(ITEMP) 
IF  ((YT  .LT.  YINT(ITEMP))  .OR.  (YT  .GT.  XINT(ITPTR))) 
YT  «  (YJNT(ITEMP)  ♦  YINT(ITPTR))/2  ♦  YINT (I TEMP) 


END  IF 
CONTINUE 

IF  ((ITPTR  .LT.  6)  .OR.  (NTH  ,LE.  2))  THEN 
GO  TO  1000 
ELSE 

NMGOOO  «  NMGOOO  *  1 
END  IF 

IF  ((SMFLG)  .AND.  (IPTS(NTH)  .NE.  4)) 

GOTO  1100 

IF((IPTS(NTH)  .EO.  4)  .AND. 

(NTH  .GT.  2))  THEN 
SMFLG  *  .TRUE. 

IPTS(I)  *  2 
X I  NT ( 1 )  -  XHOLO 
YINT(I)  •  YHOLD 
XINT<2)  «  XHOLD2 
YINT(2)  *  YHOLD2 
ITPTR  a  ITPTR  ♦  3 
NTH  *  NTH  ♦  1 
IPTS(NTH)  »  3 
IF  ( FTS  .EO.  999999)  THEN 
XINT ( I TPTR- 2)  »  XT1 
XINT (ITPTR)  *  XT2 
IF  (XBASE  .EO.  0.5)  THEN 

YINT ( ITPTR-2)  *  YTl  ♦  (NMGOCO*(1 ,/20. 'SCALE)) 
YINT(ITPTR)  *  YT2  •  (NMGOOO*( 1 ./20 . ‘SCALE ) ) 
XINT ( ITPTR* 1 )  a  ( XHOLD+X HOLD 2 ) / 2 .  ♦  (NMGOOO 

•  (1./20.  *  SCALE)) 

YINT( ITPTR- 1)  ■  (YHOLD+YHOLD2)/2. 

ELSE 

YINT( ITPTR-2)  *  YTl  -  (NMGOCO*( 1 ,/20. ‘SCALE) ) 

YINT( ITPTR)  *  YT2  ♦  (NMGOOO*(1 ,/20. ‘SCALE) ) 

XINT( ITPTR- 1)  *  (XHOLD+XHOLD2)/2.  -  (NMGOOO 

•  (1./20.  *  SCALE)) 

YINT (ITPTR- 1 )  *  (YHOLD+YHOLD2)/2. 

ENOIF 

ELSE 

IF  (FTS  .EO.  0.0)  THEN 
YINT( ITPTR -2)  a  YTl 
Y I  NT { ITPTR )  a  YT2 
IF  (XBASE  .EO.  0.5)  THEN 

XINT< ITPTR-2)  a  XT  1  •  (NKGOOO*(1 . /20 . ‘SCALE ) ) 


XINT(ITPTR)  *  XT 2  +  (NMG000*(1 ./20. ‘SCALE)) 
XINT< ITPTR- 1)  *  (XHOLO*XHOLD2)/2. 

YINT( ITPTR- 1)  «  ( Y HOLD+Y HOLD2 ) /2 .  -  (NMGOOO 
«  (1./20.  *  SOLE)) 

ELSE 

X1NT( JTPTR-2)  *  XT1  +  ( NMGOOO* ( 1 . /20 . *SCALE ) ) 
XINT(ITPTR)  ■  XT2  -  (NMGOCO*(1  ./20.*SOLE) ) 
XIMT(ITPTR-I)  «  (XHOLD+XHOLD2 )/2 . 

YINT( ITPTR- 1)  ■  ( Y HOLD* YHOLD2 ) /2 .  ♦  (HMGOOO 
•  (1./20.  *  SOLE)) 

ENOIF 

ELSE 

XINT(lTPTR-2)  *  XTl 
XINT(ITPTR)  *  XT2 
IF  (XBASE  .£0.  0.5)  THEM 

Y1NT( ITPTR-2)  »  YT1  +  (NMGOOO*(1 ./20.*SCALE)) 
YINT(ITPTR)  »  YT2  *  (NMG000*(1 ./20.*SCALE) ) 
ELSE 

Y1NT (ITPTR-2)  «  YT1  •  <NMGOOO*( 1 ./20.*SCALE) ) 
YIMT(ITPTR)  *  YT2  ♦  (NMG0CO*(1  ./20.*SOLE)) 
ENOIF 

FTSY  «  ABS( (AY(NPTS)*AY( 1 ) )/(AX(NPTS)- AX(1 ) ) ) 

IF  (FTSY  .LT.  1.0)  THEN 
IF  (XBASE  .EO.  0.5)  THEN 

XINT( ITPTR- 1)*(XHOLD*XHOLD2)/2.  ♦  (NMGOOO 

*  (1./20.  *  SOLE)) 

ELSE 

XINT( ITPTR- 1 )*(XHOLD+XHOLD2)/2.  • (NMGOOO 

*  (1./20.  *  SOLE)) 

ENOIF 

IF  (((YHOLD+YHOLD2)/2.)  .LT.  0.0)  THEN 
TINT ( ITPTR- 1 )*{YHOLD+YHOLD2)/2.  ■ 

(NMGOOO  *  (1./20.  *  SCALE))*FTSY 

ELSE 

YINT(lTPTR-1)*(YHOLD*YHOLD2)/2.  ♦ 

(NMGOOO  *  (1./20.  *  SOLE) )*FTSY 

ENOIF 

ELSE 

IF  (XBASE  .EQ.  0.5)  THEN 

XINT( ITPTR- 1 )*(XHOLO+XHOL02)/2.  +  (NMGOOO 

*  (1./20.  *  SOLE) )*FTS 

ELSE 

XINT(ITPTR-1)*(XHOLD+XHOLD2)/2.  -  (NMGOOO 

*  (1./20.  •  SCALE))*FTS 

ENOIF 

IF  (((YHOLO+YHOLD2)/2.)  .LT.  0.0)  THEN 

YINT( ITPTR- 1 )s(YHOLD+YHOLD2)/2.  •  (NMGOOO 

*  (1./20.  *  SCALE)) 

ELSE 

YINT(ITPTR-1)=(YHOLD+YHOLD2)/2.  ♦  (NMGOOO 

*  (1./20.  •  SCALE)) 


ENOIF 


00  910  I  *  2, NTH 

IPTS(I-I)  *  IPTS(I) 

CONTINUE 
NTH  *  NTH  -  1 
DO  920  I*  3,  ITPTR 
XINT(I-2>  *  XINT(l) 

YIMTCI *2)  ■  TINTd) 

ACT(l-2)  -  ACT ( I ) 

CONTINUE 

ITPTR  *  ITPTR  •  2 
ENOIF 

CONNECT  UP  THE  POINTS  FOR  THIS  CONTOUR 
CALL  C0NPTS(IPTS(NTH,1PATH, JPTR) 

YMIN  *  999999. 

DO  950  ICON  *  1,  JPTR 

XPLT (ICON)  «  XINTUPATH(ICON)) 

YPLT(ICON)  *  YINT(IPATHdCON)) 

TACT (ICON)  «  ACT( IPATH( ICON) ) 

IF  (YPLT (ICON)  .LT.  YMIN)  YMIN  *  YPLT(ICON) 

I  CONTINUE 

PLOT  THIS  CONTOUR 

SORT  THE  PTS.  SO  THEY  ARE  IN  ORDER  ACCORDING  TO  TERM  TIME 
IF  (.NOT.  SMFLG)  THEN 
I TMP  a  (JPTR-D/2 
DO  600  I  a  1 , I TMP 

TEMPAR (1 , I )  a  XPLT(I) 

TEMPAR(2, I )  a  YPLT(I) 

TEMPARC3, I )  a  TACT(I) 

CONTINUE 

IF  ( ITMP  .GT.  1)  CALL  SORTRY ( I TMP , TEMPAR , 3 ) 

DO  610  I  a  1 , ITMP 

XPLT(I)  *  TEMPAR(1,(ITMP+1-I)) 

YPLT(I)  a  TEMPARC2, < ITMP+1 *  I ) ) 

CONTINUE 

DO  615  I  a  1 , I TMP 

TEMPAR(1 , I )  a  XPLT (I+ITMP) 

TEMPAR (2, I )  a  YPLT (I+ITMP) 

TEMPAR(3, I )  *  TACT( I+ITMP) 

CONTINUE 

IF  (ITMP  .GT.  1)  CALL  SORTRY( ITMP, TEMPAR, 3) 

DO  620  I  =  1 , ITMP 

XPLT( I+ITMP)  =  TEMPAR ( 1 , I ) 

YPLT ( I+ITMP)  a  TEMPARC2, I ) 

CONTINUE 


XPLT (JPTR)  a  XPLT(1) 
YPLT(JPTR)  a  YPLT(I) 


ELSE  . 

I IMP  *  (JPTR-6J/2 

OO  630  1  *  1,ITMP 

TEMPARd , I )  «  XPLTCI) 

TEMPAR(2, I )  *  YPLT(l) 

T£MPAR(3, I )  *  TACT(I) 

630  CONTINUE 

IF  (ITMP  .GT.  1)  CALL  SORTRYC I TMP , TEMPAR , 3 ) 

00  640  I  *  1 , I TMP 

XPLT(I)  *  TEMPARd  .UTHP+1- 1)) 

YPLT(I)  *  TEMPARC2,  (ITMP+1- 1 5 ) 

640  CONTINUE 

DO  645  I  *  1 , ITMP 

TEMPARd , 1 )  *  XPLTU+ITMP+2) 

TEMPAR(2,I)  *  YPLT ( I+ITMP+2) 

TEMPAR (3, I )  *  TACT (I+ITMP+2) 

645  CONTINUE 

IF  (ITMP  .GT.  1)  CALL  SORTRY ( I TMP , TEMPAR , 3 ) 

DO  650  I  ■  1 , I TMP 

XPLT ( I+ITMP+2)  *  TEMPARd,  I) 

YPLT( I+ITMP+2)  *  TEMPARC2.I) 

650  CONTINUE 

ENOIF 

*-  CALCULATE  THE  AREA  OF  THE  CONTOUR  PLOT. 

AR  =  0.0 

DO  975  ICNT  «  2, JPTR 

BASE  »  (XPLTCICNT  -1  )  •  XPLT(ICNT)) 

HEIGHT  =  YPLTUCNT  •  1)  -  YPLT  (ICNT) 

TAR  *  0.5  *  (BASE  *  HEIGHT) 

YM  *  MI N< YPLT ( ICNT) , YPLT ( ICNT- 1 ) ) 

AR  *  AR  +(TAR  ♦  (BASE  *  (YMIN  -  YM))) 

975  CONTINUE 

AR  *  AB$(  AR/27878400.00) 


IF  (.NOT.  SMFLG)  JPTR  *  JPTR  -  1 

CALL  PLOT  I T (XPLT,  YPLT,  JPTR,  XTEMP,  YTEMP,  XBASE,  YBASE,  AR, 
♦  CONVAL(IPLT),  FTS,  SCALE,  SCRPSF,  NEUPLT) 

IF  (NMGOOO  .EO.  3)  GO  TO  1100 
1000  CONTINUE 

1100  CONTINUE 

CREATE  ANOTHER  PLOT  PAGE. 

CALL  CLSPLT 

IF  NOT  END  OF  THE  DATA  THEN  MAXE  ANOTHER  CONTOUR. 


IF  (ATIME(NPTS*1)  .EO.  8S)  THEM 
GO  TO  10 
ENO  IF 

*-  CLOSE  THE  PLOT  FILE 
400  CONTINUE 

RETURN 

ENO 


>**»»********•*»**•»»**•* 


It******************* 


******  SUBROUTINE  CCONVL 


*«*••»****•*»*»-»»■•**•**»■*» 


HOOULE  NAME  :  CCONVL 
MODULE  TYPE  :  SUBROUTINE 

PROGRAMMER  :  HARRY  SEIOMAN 
DATE  :  DECEMBER  1986 

REVISIONS  :  APRIL  1987,  UPDATED  TO  CONVERT  TO  PSF  ALSO. 

DESCRIPTION  : 

THE  PURPOSE  OF  THIS  SUBROUTINE  IS  TO  CONVERT  THE  PRESS 
FROM  PASCALS  TO  DB  OR  PSF.  FIND  THE  MAXIUM  PRESSURE,  AND 
SELECT  THE  10  TOP  CONTOUR  VALUES  TO  PLOT. 

HOOULE  I/O  : 


INPUTS  : 

PRESS  •  REAL (1000)  :  PRESSURE  IN  PASCALS. 

NPTS  •  INTEGER  :  NUMBER  OF  PTS  IN  THE  PRESS  ARRAY. 

SCRPSF  •  LOGICAL  :  TRUE  IF  PRESS  IS  TO  BE  CONVERTED  TO  PSF. 

OUTPUTS  : 

PRESS  •  REAL (1000)  :  PRESSURE  IN  DB  OR  PSF. 


VARIABLE  DICTIONARY  : 


TVAL1  •  REAL (40)  :  CONTOUR  LEVELS  IN  DB. 

TVAL2  •  REAL (40)  :  CONTOUR  LEVELS  IN  PSF. 


CALLED  MOOULES  :  NONE 


CALLING  MODULE  : 


SCRPAD  •  SUBROUTINE  THAT  DRIVES  THE  SCRACHPAD  PLOTTING  ROUTINE 


SUBROUT  I NE  CCONVL (PRESS , NPTS , CONVAL , SCRPSF ) 

LOGICAL  SCRPSF 

DIMENSION  PRESS(NPTS) ,  CONVAL ( 10) , TVAL1 (40 ) , TVAL2(40) , TVALC40) 

DATA  TVAL 1/70., 72. 5, 75., 77. 5, 80., 32. 5, 85., 87.5, 

1  90., 92.5,95., 97. 5,100., 102. 5, 105., 107. 5, 


2 

3 

4 


110. 5. 112. 5. 115..  117.5. 120.. 122. 5. 125.. 127. 5, 

130. 5. 132. 5. 135..  137.5. 140.. 142. 5. 145.. 147.5, 

150.5. 152.5. 155..  157.5. 160.. 162.5. 165.. 167.5, 


C 

C 

C 

C 


DATA  TVAL2/ . 0078 1 25 , . 01 1 72 , 0 1 5625 , . 0234375 ,.03125,. 046875 , . 0625 , 

1  .09375, .125,  1875, .25, .375, .5, .75,1. ,1.5, 2. ,3. ,4. ,6., 

2  8., 12., 16., 24., 32., 52.. 64., 96., 128., 256, 320., 512., 768.. 

3  1024., 1536., 2048., 3072., 4096., 6144., 8192./ 

CONVERTING  DATA  FROM  PASCALS  TO  08. 

ALSO  FIND  THE  MAXIMUM  VALUE 

PMAX  *  -1.E30 


CONVERT  THE  INPUTED  PRESSURE  TO  08  OR  PSF. 

DO  100  I  «  1.NPTS 
IF  (SCRPSF)  THEN 

PRESS(l)  »  PRESS! I)  /  47.85 
ELSE 

PRESSCI)  *  10.  *  ALOG10(PRESS!I )  •  PRESS!!))  ♦  94.0 
END  IF 

PMAX  *  AMAX1 (PMAX ,PRESS( I ) ) 

100  CONTINUE 

*.  INITIALIZE  TVAL  WITH  THE  CORRECT  CONTOUR  LEVELS  IE.  PSF/DB. 

DO  110  I  «  1,40 
IF  (SCRPSF)  THEN 

TVAL! I)  »  TVAL2C) 

ELSE 

TVAL!  1 "  a  TVALKI) 

ENOIF 
110  CONTINUE 

C 

C  IDENTIFY  THE  MAXIMUM  CONTOUR,  I.E.  THE  FIRST  CONTOUR  VALUE 

C  LESS  THAN  OR  EQUAL  TO  THE  MAX  PRESSURE. 

C 

DO  200  I  a  1  ,  40 
IC  a  40  •  I  ♦  1 

IF(PMAX  .G£.  TVAL ( I C ) >  GO  TO  250 
200  CONTINUE 
250  CONTINUE 
C 

c 

C  SET  THE  TEN  CONTOUR  VALUES 

C 

DO  300  I  *  1,10 

CONVAL(I)  a  TVAL!  IC  -  I  ♦  D 
300  CONTINUE 
RETURN 
END 


*****««««************••*****#«****•****»*****•*»»*»*****************«*** 
MMttMMMMtMmttMiM*  SUBROUTINE  FNDCNT  •»****•**»*”«****•»**•** 
****************«*•*«*•*«***#«*•*#***«'**********«***********»*****«***«* 


*-  MODULE  NAME  :  FNDCNT 
*•  MOOULE  TYPE  :  SUBROUTINE 


PROGRAMMER  :  HARRY  SEIDMAN 
DATE  :  DECEMBER  1986 

REVISIONS  :  APRIL  1987,  UPOATE  TO  SEARCH  FROM  FAR  ENO  OF  ARRAY  FOR 

CONTOUR  VALUES  IF  TWO  ARE  ALREADY  FOUND. 

DESCRIPTION  : 

THE  PURPOSE  OF  THIS  ROUTINE  IS  TO  TAKE  AN  ARRAY  OF 
PRESSURES  ,  INTERPOLATE  THE  DATA  TO  FIND  THE 
NUMBER  OF  TIMES  THAT  THE  DESIRED  CONTOUR  VALUE 
EXISTS  FOR  EACH  THIS  TIME  HACK,  AND  FIND  THE 
THE  INTERPOLATED  X  AN  Y  LOCATION  WHERE  THE  CONTOUR 
BELONGS. 


*•  MOOULE  I/O  : 

* . 

*. 

*•  INPUTS  : 

*•  PRESS  •  REAL (1000)  :  PRESSURE  IN  PASCALS  RETURNED  IN  DB  OR  PS 

*•  RX  •  REAL(IOOO)  :  X  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 

**  RY  -  REAL (1000)  :  Y  COORDINATE  OF  WHERE  THE  RAY  TERMINATES 

*•  NPPH  -  INTEGER  :  NUMBER  OF  PTS  IN  THIS  CURRENT  TIME  HACK. 

•-  CONVAL  •  REAL  :  CURRENT  CONTOUR  VALUE  BEING  SEARCHED  FOR 

*•  OUTPUTS: 

*•  ITPTR  -  INTEGER  :  NUMBER  OF  PTS  FOUND  FOR  THIS  CONTOUR  LEV 

*•  XINT  •  REAL (1000)  :  X  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 

*•  TINT  •  REAL (1000)  :  Y  COORDINATE  OF  INTERPOLATED  PTS  FOR  CON 

*•  ICNT  •  INTEGER  :  NUMBER  OF  PTS  FOUND  FOR  CURRENT  TIME  HAC 


*•  VARIABLE  DICTIONARY  : 


*■  CALLED  MOOULES  :  NONE 


*-  CALLING  MOOULE  : 


SCRPAD  ■  SUBROUTINE  THAT  DRIVES  THE  SCRACHPAD  PLOTTING  ROUTINE 


SUBROUTINE  FNDCNT(PRESS,X,Y,NPTS, CONVAL, ITPTR, XINT, TINT, ICNT, 
1  ACT  I ME , ACT) 


DIMENSION  PRESS(NPTS) ,  X(NPTS),  Y(HPTS),  ACTIME(NPTS) 
DIMENSION  XINT(1500),  YINT(ISOO),  ACT<1500) 


C 

C 

c 

c 

c 


SET  UP  A  COUNTER  TO  MAKE  SURE  WE  DO  NOT  FIND  MORE  THAN 

FOUR  OCCURANCES  OF  A  CONTOUR  VALUE  DURING  ONE  TIME  HACK 


ICNT*  0 


*-  START  AT  THE  SEGINING  OF  THE  TIME  HACK. 

DO  100  I  *  2,  NPTS 
C 

I F(CONVAL  .GT.  PRESSU-1)  .AND.  CONVAL  .LT.  PRESS(I))  THEN 
FACTOR  »  (CONVAL  -  PRESSU -1))  /  (PRESS(I>  •  PRESSU -1>) 

ITPTR  ■  ITPTR  *  1 

XINT(ITPTR)  *  X(I-1)  ♦  (  XU)  •  X(I-1)  )  *  FACTOR 
TINT  (ITPTR)  *  YU-1)  ♦  (  T(  I )  -  T(I-1)  )  *  FACTOR 
ACT  (I TPTR  )*  ACT  1  HE  (1  ■  1  )♦(  ACT  I  ME  (I )  •  ACT  IME  (I  - 1 )  )*  FACTOR 
ICNT*  ICNT*  1 
IFOCNT.EO.  2)  THEN 
IHOLO  *  I 
GO  TO  110 
ENO  IF 
C 

ELSE I F{( CONVAL  .LT.  PRESSU-1))  .AND.  (CONVAL  .GT.  PRESS(9)) 

1  .AND.  (ICNT  .EG.  D)  THEN 

FACTOR  *  (CONVAL  -  PRESS(I-I))  /  (PRESS(I)  •  PRESSU -1)) 

ITPTR  *  ITPTR  ♦  1 

XINT(ITPTR)  .  X(I-I)  +  (  XU)  •  X(  I  - 1 )  )  *  FACTOR 
YINT(ITPTR)  »  TU-1)  ♦  (  TU)  -  Y(I - 1  >  )  *  FACTOR 
ACT  (ITPTR)*  ACTIMEU  -1  )+(ACTIME(  I  )-ACTIME(I  •  1  ))*FACTOR 
ICNT*  ICNT*  1 
IFUCNT.EO.  2)  THEN 
I  HOLD  *  I 
GO  TO  110 
END  IF 
C 

END  IF 
C 

100  CONTINUE 
C 

RETURN 

*•  SEARCH  FROM  THE  FAR  END  OF  THE  TIME  HACK  TO  SEE  IF  ANY  MORE  PTS  EX 
110  CONTINUE 
IT  *  1 

DO  200  1=  (NPTS- 1 )  ,  I  HOLD,  -1 

IF( (CONVAL  .GT.  PRESS(IU))  .AND. (CONVAL  .LT.  PRESSU)) 

1  .ANO.  (ICNT  .EO.  3))  THEN 

FACTOR  *  (CONVAL  -  PRESSU+1))  /  (PRESSU)  -  PRESS(I*1)) 

ITPTR  *  ITPTR  +  1 


X1NTUTPTR  ♦  IT)  *  XU+1)  ♦  (  X<!>  •  XU+1)  )  *  FACTOR 

YINTCITPTR  ♦  IT)  «  Y(I+1)  ♦  (  YCI)  •  Y(I+1)  )  *  FACTOR 

ACTUTPTR+IT)*  ACTIMEU+1  )+<ACTIME<  1  )-ACTIME(  1+1  ))*FACTOR 
I CRT*  ICNT+  1 
IF  (I CRT  .£0.  3)  IT  *  -1 
IFUCNT.EO.  4)  RETURN 
C 

ELSEI FCCONVAL  .LT.  PRESSU  +  1)  .AND.  CONVAL  .GT.  PRESS(D)  THEN 
FACTOR  «  (CONVAL  •  PRESSU+1))  /  (PRESSU)  •  PRESSU+1)) 
ITPTR  =  ITPTR  ♦  1 

XINTUTPTR  ♦  IT)  *  XU+1)  ♦  (  XU)  -  XU+1)  )  *  FACTOR 

YINTUTPTR  ♦  IT)  «  YU+1)  ♦  (  Y(I)  •  YU+1)  )  *  FACTOR 

ACTUTPTR+IT)*  ACTIMEU+1)+<ACT1MEU)-ACTIMEU+1))*FACT0R 
I CRT*  ICRT+  1 
IF  (I CRT  .£0.  3)  IT  =  -1 
IFUCNT.EO.  4)  RETURN 
C 

ENOIF 

200  CONTINUE 
RETURN 
END 


*********«*****#****«*******•***«*********#*«•«********************«#+** 


SUBROUTINE  PSETUP 


*#** 

**«* 


*-  MODULE  NAME  :  PSETUP 
•-  MOOULE  TYPE  :  SUBROUTINE 

••  PROGRAMMER  :  THOMAS  REILLY 
*-  DATE  :  DECEMBER  12,  1986 

*•  REVISIONS  : 

*•  DESCRIPTION  : 

*-  THE  PURPOSE  OF  THIS  SUBROUTINE  IS  TO  SET  UP  THE  PLOT  P 

*•  THE  SCRATCH  PAD.  THE  FLIGHT  TRACK  IS  PLOTTED,  FLIGHT  INFOR 

*•  IS  PLOTTED,  AND  THE  SCALE  IS  PLOTTED,  MAP  ORIENTATION  IS  PL 

*•  aNO  FLIGHT  IDENTIFICATION  IS  PLOTTED. 


MOOULE  I/O 

PSETUP  (AX, 

AY,  AZ,  NPTS,  XTEMP,  YTEMP ,  XBASE,  YBASE, 

ATIME,  FTS, SCALE). 

INPUTS  : 

INCLUDING  COMMON  BLOCKS. 

ACTYPE 

CHAR<8) 

TYPE  OF  AIRCRAFT  THAT  IS  BEING  FLOWN. 

AT  I  ME 

REAL (1000) 

ARRAY  OF  TIMES  FOR  THE  X,Y,Z  COORDINATES 

OF  THE  A/C. 

AX 

REAL (1000) 

ARRAY  OF  X  COORDINATES  OF  THE  FLIGHT  TRA 

AY 

REAL (1000) 

ARRAY  OF  Y  COORDINATES  OF  THE  FLIGHT  TRA 

A2 

REAL (1000) 

ARRAY  OF  Z  COORDINATES  OF  THE  FLIGHT  TRA 

C8LEV 

REAL 

CARPET  BOOM  LEVEL  USING  CARLSONS  METHOO. 

EMACHN 

REAL 

ENDING  MACH  NUMBER. 

MAXOP 

REAL 

MAXIMUM  OVERPRESSURE  VALUE. 

MOATE 

CHAR(8) 

DATE  OF  THE  MISSION. 

MNAME 

CHAR(16) 

MISSION  NAME. 

MSITE 

CHAR(IO) 

SITE  OF  THE  MISSION. 

NPTS 

INTEGER 

NUMBER  OF  POINTS  IN  THE  FLIGHT  TRACK  ARR 

SMACHN 

REAL 

STARTING  MACH  NUMBER 

TAILN 

CHAR(8) 

TAIL  NUMBER  OF  THE  AIRCRAFT. 

XCOORD 

REAL 

X  COORDINATE  OF  THE  MAXIMUM  OVERPRESSURE 

YCOORD 

REAL 

Y  COORDINATE  OF  THE  MAXIMUM  OVERPRESSURE 

Z COORD 

REAL 

Z  COORDINATE  OF  THE  MAXIMUM  OVERPRESSURE 

OUTPUTS  : 

INCLUDING  COMMON  BLOCKS. 

FTS 

REAL  : 

SLOPE  OF  THE  FLIGHT  TRACK. 

SCALE 

• 

REAL 

SCALE  OF  THE  FLIGHT  TRACK  AND  CONTOURS. 

X8ASE 

REAL  : 

X  COORD  OF  THE  BASE  TO  PLOT  THE  CONTOUR  F 

XTEMP  •  REAL  :  X  COORD  OF  THE  FIRST  ELEMENT  OF  THE  FLIGH 
TBASE  •  REAL  :  Y  COORD  OF  THE  BASE  TO  PLOT  THE  CONTOUR  F 
YTEMP  •  REAL  :  Y  COORD  OF  THE  FIRST  ELEMENT  OF  THE  FLIGH 


VARIABLE  DICTIONARY  : 


ALT  -  REAL  :  ALTITUDE  OF  THE  AIRCRAFT. 

HR  -  REAL  :  USED  TO  CONVERT  INPUTED  TIME  INTO  HOURS. 
NMAX  •  INTEGER  :  INDICE  OF  THE  LARGEST  Y  COORDINATE. 

MIN  •  REAL  :  USED  TO  CONVERT  INPUTED  TIME  INTO  MINUTS. 
SEC  -  REAL  :  USED  TO  CONVERT  INPUTED  TIME  INTO  SECOUND 
T1  •  REAL  :  DUMMY  VARIABLE  USED  TO  PLOT  A  0. 

X  •  REAL  :  USED  TO  CALCULATE  REAL  X  COORO  INTO  IHCHE 
Y  -  REAL  :  USED  TO  CALCULATE  REAL  Y  COORD  INTO  INCHE 
YMAX  •  REAL  :  LARGEST  Y  COORDINATE  VALUE. 


CALLED  MODULES  : 


SORT FT  (AT1ME,  AX,  AY,  NPTS) ; 

THIS  SUBROUTINE  IS  USED  TO  SORT  THE  FLIGHT  TRACK  ON  TIME. 

PLOT  (X,  Y,  PENSTATE);  PLOTS  A  STRAIGHT  LINE. 

X  -  REAL  :  X  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 

Y  •  REAL  :  Y  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 

PENSTATE  ■  INTEGER  :  STATUS  OF  THE  PEN,  (UP,  DOWN,  NEW  ORIG 

SYMBOL  (X,  Y,  SIZE,  STRING,  ANGEL,  NCHAR);  PLOTS  A  CHARACTER  STRIN 

SIZE  -  REAL  :  SIZE  OF  THE  CHARACTER  IN  INCHES. 

STRING  •  CHAR<*)  :  CHARACTER  STRING  TO  BE  PLOTTED. 

ANGEL  •  REAL  :  ANGEL  STRING  IS  TO  BE  PLOTTED  AT. 

NCHAR  •  INTEGER  :  NUMBER  OF  CHARACTERS  TO  BE  PLOTTED. 

NUMBER  (X,  Y,  SIZE,  NUM,  ANGEL,  DPLACE);  PLOTS  A  NUMBER. 

NUM  •  REAL  :  NUMBER  TO  BE  PLOTTED. 

DPLACE  •  INTEGER  :  NUMBER  OF  DECIMAL  PLACES  TO  BE  PLOTTED 


CALLING  MOOULE  : 


SCRPAD  (); 

SUBROUTINE  THAT  DRIVES  THE  SCRATCH  PAD  PLOTING. 


SUBROUTINE  PSETUP  (AX,  AY,  AZ,  NPTS,  XTEMP,  YTEMP,  XBASE,  YBASE, 
1  ATIME,  FTS,  SCALE) 


DECLARATION  OF  SUBROUTINE  INPUT/OUTPUT  VARIABLES. 

COMMON  /HEADER/  MNAME,  MOATE,  MSITE,  ACTYPE,  TAILN 
COMMON  /OPREC/  SMACHN ,  C8LEV,  MAXOP,  X COORD,  YCOORD,  ZCOORD , 
1  EMACHN 


REAL 

REAL 

REAL 

CHARACTER*8 
CHARACTER* 10 
CHARACTER* 16 


MAXOP,  CBLEV,  XCOORD,  YCOORD,  ZCOORD 
XBASE,  YBASE,  XTEMP,  YTEMP,  AX(4000) 
AY (4000) ,  AZC4000),  ATIME<4000) 
ACTYPE,  MOATE,  TAILN 
MS1TE,  UT,  LONG 
MNAME 


DECLARATION  OF  SUBROUTINE  DEPENDANT  VARIABLES. 

REAL  HR,  MIN,  SEC,  ALT,  T1,  X,  Y,  SCALE 


DETERMINE  WEATHER  THE  FLIGHT  TRACK'S  SLOPE  IS  (■)  OR  (♦) 

CALL  PLOTS 

CALL  PLOT (8.5,0. , -3) 

XBASE  >0.0 
YBASE  >0.0 

IF  (AX(1)  .EO.  AX(NPTS) )  THEN 
FTS  «  0.0 
ELSE 

IF  (AY(1 )  .EO.  AY(NPTS) )  THEN 
FTS  >  999999. 

ELSE 

FTS  »  A8S( ( (AX(NPTS)  •  AX(1))  /  (AY(NPTS)  -  AY(1)))) 
END  IF 
END  IF 


CY  >  AY(NPTS)  •  AY( 1 ) 

CX  *  AX(NPTS)  -  AX(1) 

CALL  NEWPEN(2) 

CALL  PLOT (2. 0,7. 63, 3) 

CALL  PLOT (2. 2, 7. 63, 2) 

CALL  NEWPEN(I) 

CALL  SYMBOL(2.3,7.6,O.D9, '  •  FLIGHT  TRACK' ,0.0, 15) 

CALL  SYMBOL(7.25,7.55,0.20, '♦',0.0,1) 

CALL  SYM8OL(7.35,7.6,0.09, '  •  MAX  OVERPRESSURE ' ,0.0, 19) 

CALL  PLOT(0.25,2.3,3) 

CALL  PLOT(0.25,7.5,2) 

CALL  PLOT(10.5,7.5,2) 

CALL  PLOT (10.5,2.3,2) 

CALL  PLOT (0.25 ,2.3,2) 

CALCULATE  THE  BASE  FOR  THE  FLIGHT  TRACK. 

IF  (FTS  .GE.  1.0)  THEN 
IF  (CY  .LT.  0)  THEN 


IF  ((FTS  .  GE .  0.0}  .AND.  (FTS  .IE.  0.5))  YBASE  =  0.0 

IF  ((FTS  .GT.  0.5)  .AMO.  (FTS  .IE.  1.0))  YBASE  *  0.0 

END  IF 

IF  (CY  .GT.  0)  THEM 

IF  ((FTS  .GE.  0.0)  .AMO.  (FTS  .LE.  0.5))  YBASE  *  0.0 

IF  ((FTS  .GT.  0.5)  .AMD.  (FTS  .LE.  1.0))  YBASE  =  0.0 

END  IF 

IF  (CX  .GT.  0)  THEN 
XBASE  >0.5 
YBASE  *  YBASE  *5.0 
ELSE 

XBASE  »  10.0 
YBASE  *  YBASE  *5.0 
ENOIF 

PLOT  NORTH  UP. 

CALL  PLOT  (5.2,7.90,3) 

CALL  PLOT  (5.3,7.95,2) 

CALL  PLOT  (5. 4, 7. 9, 2) 

CALL  PLOT(5.3,7.95,3) 

CALL  PLOT  (5.3,7.75,2) 

CALL  SYMBOL (5. 25, 7. 55, . 14,* N', 0.0,1) 

SCALE  -  (ABS( INT (CX/30000) )  *  1)  *  30000 

PLOT  THE  FLIGHT  TRACK  OF  THE  AIRCRAFT. 

CALL  NEWPEN(2) 

CALL  PLOT (XBASE, YBASE,  3) 

DC  30  I  »  2,  NPTS 

Y  =  (AY( I )  •  AY( 1 ) )/  SCALE  *  YBASE 

X  *  (AX(I)  •  AX( 1 ) )/  SCALE  ♦  XBASE 

CALL  PLOT  (X, Y, 2) 

CONTINUE 
CALL  NEUPEN(I) 

X  *  ( ( (XCOORD  •  AX( 1 ) )/SCALE)  ♦  XBASE)  •  0.075 

Y  s  ( ( (YCOORD  •  AY(1  D/SCALE)  *  YBASE)  •  0.075 

PLOT  A  (*)  AT  THE  COORDINATES  OF  THE  MAX  I HUN  OVERPRESSURE. 
CALL  SYMBOL(X, Y, . 20, 0.0,1) 

ELSE 

PLACE  NORTH  AT  EAST. 

CALL  SYMBOLS. 95, 7. 75,  .14,  'N'  ,0.0,1) 

CALL  PlOT(5 . 1 ,7.8,3) 

CALL  PLOT  (5. 3, 7. 8, 2) 

CALL  PLOT  (5.25,7.9,2) 

CALL  PLOT  (5.25,7.7,3) 

CALL  PLOT  (5.3, 7.3,2) 

IF  (CX  .LT.  0)  THEN 

IF  ((FTS  .GT.  0.0)  .ANO.  (FTS  .LE.  0.5))  YBASE  =  0.0 
IF  ((FTS  .GT.  0.5)  .AND.  (FTS  .LE.  1.0))  YBASE  =  0.0 
ENOIF 


IF  CCX  .GT.  0)  THEM 

IF  ((FTS  ,GT.  0.0)  .AMO.  (FTS  .LE.  0.5))  YBASE  *  0.0 
IF  ((FTS  .GT.  0.5)  .AND.  (FTS  .LE.  1.0))  YBASE  *  0.0 
EMOIF 

IF  (CY  .GT.  0)  THEN 
XBASE  *  0.5 
YBASE  *  YBASE  ♦  5.0 
ELSE 

X8ASE  >  10.0 
YBASE  *  YBASE  +  5.0 
EMOIF 

SCALE  «  (ABS(INT(CY/30000))  +  1)  *  30000 

PLOT  THE  FLIGHT  TRACK  OF  THE  AIRCRAFT. 

CALL  NEWPEN(2) 

CALL  PLOT (X8ASE, YBASE,  3) 

DO  35  I  *  2,  NPTS 

Y  »  <AY( I )  •  AY<1 ))/  SCALE 
X  «  (AX(I)  -  AX(1 ))/  SCALE 
Y1  «  Y 

Y  *  X  •  (-1)  ♦  YBASE 
X  *  Y1  ♦  XBASE 

CALL  PLOT  (X,Y ,2) 

CONTINUE 
CALL  NEWPEN(I) 

X  =  ( ( X COORD  ■  AX(1))/SCALE) 

Y  =  (CYCOORO  •  AY<1))/SCALE) 

Y1  *  Y 

Y  *  (X  *  (-1)  ♦  Y8ASE )  •  0.075 
X  *  (Y1  ♦  XBASE)  •  0.075 

PLOT  A  (♦)  AT  THE  COORDINATES  OF  THE  MAXIMUN  OVERPRESSURE. 
CALL  SYMBOLS, Y,  .20,  0.0,1) 

END  IF 


PLOT  THE  A/C  TYPE  ANO  TAIL  NUMBER. 

CALL  SYMBOL (0.6,2. 1,-09, 'A/C  TYPE  :  ’,0.0,15) 

CALL  SYMBOL (1. 9,2.1, .09, ACTYPE ,0.0,8) 

CALL  SYMBOL (3. 7, 2. 1 , .09, 'TAI L  #  :  ’,0.0,13) 

CALL  SYMBOL <4. 8, 2. 1 , .09, TAI LN, 0.0, 8) 

CALCULATE  AND  PLOT  THE  STARTING  TIME  OF  THE  FLIGHT  TRACK. 
HR  *  I  NT (ATIME( 1 )/3600) 

MIN  *  IHT ( CAT  I  ME  < 1 )  ■  (HR  *  3600))  /  60) 

SEC  =  ATIME(I)  •  ((HR  *  3600)  ♦  (MIN  *  60)) 

CALL  $YM80L(0.6, 1 .9, .09, 'START  TIME  :  ’,0.0,15) 

IF  (HR  .LT.  10)  THEN 
T1  *  0.0 

CALL  NUMBER (1 .9,1.9,.09,T1,0.0,-1) 

CALL  NUMBER (2.0, 1 .9, . 09, HR , 0. 0, • 1 ) 


ELSE 

CALL  NUMBER (1 . 9, 1. 9, .09, HR ,0. 0,-1) 

END  IF 

CALL  SYM80L<2.1, t. 9, 0.09, •:*, 0.0,1) 

IF  (MIN  .LT.  10)  THEN 
T1  *  0.0 

CALL  NUMBER(2.2,1 .9, .09,T1,0.Q,-1) 

CALL  NUMBER(2.3,1.9,.09,M!N,0.0,-1) 

ELSE 

CALL  NUMBER(2.2,1.9,0.09,MIN,Q.0,-1) 

END  IF 

LF  (SEC  .LT.  10.0)  THEN 

CALL  SYMBOL (2. 4, 1 .9,0.09, 1 :0' ,0.0,2) 

CALL  NUMBER(2.6, 1 .9,0.09, SEC, 0.0, 2) 

ELSE 

CALL  SYMBOL(2. 4, 1.9, 0.09,': ',0.0,1) 

CALL  NUMBER(2.S,1.9,0.09,SEC,0.0,2) 

ENOIF 

PLOT  THE  ALTITUDE  OF  THE  FLIGHT  TRACK  A  THE  STARTINE  POINT. 
CALL  SYMBOL(0. 6, 1.7,0.09, 'START  ALT  :  ',0.0,15) 

ALT  *  AZ(1)/1000 

CALL  NUMBER(1 .9, 1 .7, 0.09, ALT, 0.0, 2) 

CALL  SYMBOL(2.5, 1.7,0.09, *K  FEET', 0.0, 6) 

PLOT  THE  MAP  SCALE. 

CALL  NUMBER(7.7,  2.1,  0. 09, SCALE, 0. 0, - 1 ) 

CALL  SYMBOL(8.2,2.1 ,0.09, 'FT', 0.0, 2) 

CALL  PLOT  (7.5,  2.0,3) 

CALL  PLOT  (8.5,  2.0,2) 

CALL  PLOT  (7.5,  1.95,  3) 

CALL  PLOT  (7.5,  2.05,  2) 

CALL  PLOT  (8.5,  1.95,  3) 

CALL  PLOT  (8.5,  2.05,  2) 


CALCULATE  ANO  PLOT  THE  ENDING  TIME  OF  THE  FLIGHT  TRACK. 
HR  *  1NT(ATIME(NPTS)/3600) 

MIN  *  INT((AT!ME(NPTS)  •  (HR  *  3600))  /  60) 

SEC  *  ATIME(NPTS)  -  ((HR  *  3600)  ♦  (MIN  *  60)) 

CALL  SYMBOL(3.7,1 .9,0.09, 'END  TIME  :  ',  0.0,  13) 

IF  (HR  .LT.  10)  THEN 
T1  *  0.0 

CALL  NUM8ER(4.8, 1 .9, .09,T1 ,0.0, - 1 ) 

CALL  NUM8ER(4.9, 1 .9, .09, HR, 0.0, • 1 ) 

ELSE 

CALL  NUMBER (4, 8, 1 .9, .09, HR, 0.0, ■ 1 ) 

END  IF 

CALL  SYM80L(5. 0,1.9,0.09, 0.0,1) 

IF  (MIN  .LT.  10)  THEN 
T1  *  0.0 

CALL  NUMBER (5.1.1.9,. 09 ,T1,0.0,-1) 

CALL  NUMBER ( 5. 2, 1.9, .09, MIN, 0. 0,-1) 

ELSE. 


CALI  NUMBER ( 5. 1 , 1 .9,0. 09 ,MIN,0.0, -1 } 

END  IF 

IF  (SEC  .LT.  10.0)  THEN 

CALL  SYMBOL (5.3, 1 .9,0. 09, ':0', 0.0, 2) 

CALL  NUMBER(5.5, 1 .9, 0.09, SEC, 0.0, 2) 

ELSE 

CALL  SYMBOL (5. 3, 1 .9,0.09, 0.0,1) 

CALL  NUM6ER(5.4, 1 .9, 0.09, SEC, 0.0, 2) 

END  IF 

PLOT  THE  ALTITUDE  OF  THE  END  OF  THE  FLIGHT  TRACK. 

CALL  SYMBOL(3.7,1.7,0.09, 'END  ALT  :  ',0.0,13) 

ALT  *  A2(NPTS)/1000 

CALL  NUMBER (4. 8, 1 .7, .09, ALT, 0.0, 2) 

CALL  SYMBOL (5. 4, 1 .7, .09, 'K  FEET  ',0.0,7) 

PLOT  THE  MACH  NUMBER,  CARPET  BOOM  LEVEL,  AND  MAXIMUM  OVERPRESSURE. 
CALL  SYM8OL(0.6,1.5, .09, 'START  MACH  #  :  *,0.0,15) 

CALL  NUM8ERO  .9,1.5, . 09, SMACHN , 0 .0,4) 

CALL  SYMBOL(3.7,1.5, .09, 'END  MACH  #  :  ',0.0,13) 

CALL  NUMBER(4.8,1 .5, .09, EMACHN , 0.0,4) 

CALL  SYMBOL(0. 6, 1.15,. 09, 'CARPET  BOOM  LEVEL  :  >,0.0,23) 

CALL  NUMBER  (2.6, 1 . 15, .09,CBLEV,0.0,2) 

CALL  SYMBOL  (3. 1 , 1 . 15, .09, ' PSF ' ,0.0,3) 

CALL  SYMBOL (0.6, 0.95,. 09, 'MAX I MUM  OVERPRESSURE  :  ',0.0,23) 

MAX OP  «  MAXOP  /  47.85 

CALL  NUMBER  (2.6, .95, .09, MAXOP, 0.0, 2) 

CALL  SYMBOL(3.1,.95,.09, 'PSF' ,0.0,3) 

CALL  SYMBOL(0. 6, 0.75, .09, 'ENHANCEMENT  FACTOR  :  ',0.0,23) 

IF  (C8LEV  .GT.  0.0)  EFACT  *  MAXOP  /  C8LEV 
CALL  NUMBER (2. 6, 0.75, .09, EFACT, 0.0, 2) 

CALL  SYMBOL  (3. 7, 1 . 15, .09, ' RANGE  CENTER ' ,0.0, 12) 

CALL  RNGLL(MSITE,  LAT,  LONG) 

CALL  SYMBOL  (3.7,0.95, .09, 'LAT  :  ’,0.0,7) 

CALL  SYMBOL  (4.3 , 0.95 ,. 09, LAT ,0.0, 10) 

CALL  SYMBOL  (3.7,0.75, .09, 'LONG  :  ',0.0,7) 

CALL  SYMBOL  (4.3,0.75, .09, LONG, 0.0, 10) 

PLOT  THE  COORDINATE  VALUES  OF  THE  MAXIMUM  OVERPRESSURE. 

CALL  SYMBOL (6. 5,  1 . 55 , .09 , 1  COORD  I  NATES  OF  MAXIMUM  OVERPRESSURE' 

1  ,0.0,35) 

CALL  SYMBOL(6.8, 1 .35 , .09, 'X  COORDINATE  :  ',0.0,17) 

CALL  NUMBER (8. 3, 1 .35, .09, (XCOORD/IOOO) , 0.0,2) 

CALL  SYMBOL ( 9 . 0 , 1 . 35 , . 09 , ' K  FEET  ’,0.0,7) 

CALL  SYMBOL(6.8,1.15,.09,'Y  COORDINATE  :  ',0.0,17) 

CALL  NUMBER (8. 3, 1.15, .09, (YCOORD/IOOO) ,0.0,2) 

CALL  SYMBOL;9.0, 1 . 15, .09, 'K  PEET  ’,0.0,7) 

CALL  SYMBOLC6. 8, .95, .09, 'ALTITUDE  :  ',0.0,17) 

CALL  NUMBER (8. 3 , .95 , . 09, (ZCOORD/IOOO) , 0.0,2) 

CALL  SYMBOL (9.0, .95 , .09, ' K  FEET  ',0.0,7) 


PLOT  THE  FLIGHT  SEGMENT  IDENTIFICATION. 


CALI  SYM80L(6.5,Q.6, .09, 'FLIGHT  SEGMENT  IDENTIFICATION1 ,0.0,29) 
CALL  SYMBOLS. 8, 0.4,. 09,  'MISSION  NAME  :  ',0.0,17) 

CALL  SYMBOL (8. 3, 0.4, .09,MNAME ,0.0, 16) 

CALL  SYMBCLC6. 8, 0.2,. 09, 'MISSION  DATE  :  ',0.0,17) 

CALL  SYM80L(8.3,0.2,.09,MDATE,0.0,8) 

CALL  SYM80LC6. 8, 0.0,. 09, 'MISSION  SITE  :  ',0.0,17) 

CALL  SYMBOL(8.3,0.0,.09,MSITE,0.0,10) 

XTEMP  »  AX< 1 ) 

YTEMP  «  AY(1 ) 

RETURN 

END 

END  OF  SUBROUTINE  PSETUP. 
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MODULE  NAME  :  PLOTIT 
MGOULE  TYPE  :  SUBROUTINE 

PROGRAMMER  :  THOMAS  REILLY 
DATE  :  JANUARY  5,  1986 

REVISIONS  : 

DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  PLOT  THREE  CONTOUR  LEVE 
FOR  THE  SCRATCH  PAD  PLOTS.  IT  ALSO  PLOTS  THE  AREA  OF  EACH 
OF  THE  CONTOUR  LEVELS. 


MOOULE  I/O  :  PLOTIT  (XPLT,  YPLT,  JPTR,  XTEMP,  YTEMP,  XBASE,  YBASE, 
.  CONVAL,  SCALE,  FTS,  SCRPSF) 


INPUTS  : 
AR 

CONVAL 

JPTR 

FTS 

SCALE 

SCRPSF 

XBASE 

XPLT 

XTEMP 

Y8ASE 

YPLT 

YTEMP 


•  REAL  :  AREA  OF  THE  CONTOUR  LEVEL. 

•  REAL  :  CONTOUR  LEVEL  VALUE. 

•  INTEGER  :  NUMBER  OF  POINTS  IN  THE  ARRAYS  YPLT,  XPLT 

•  REAL  .*  SLOPE  OF  THE  FLIGHT  TRACK. 

•  REAL  :  SCALE  OF  THE  FLIGHT  TRACK  AND  CONTOURS. 

-  LOGICAL  :  TRUE  IF  THE  CONTOURS  ARE  IN  PSF. 

•  REAL  :  X  COORDINATE  BASE  FOR  THE  CONTOUR  LEVELS. 

•  REAL (1000)  :  X  COORD  OF  THE  CONTOUR  POINTS  TO  BE  PLOT 

•  REAL  :  X  COORD  USED  TO  CALCULATE  DISTANCE  FROM  T 

XBASE. 

■  REAL  :  Y  COORDINATES  BASE  FOR  THE  CONTOUR  LEVEL 

•  REAL (1000)  :  ARRAY  OF  Y  COORDINATES  OF  THE  CONTOUR  PO 

TO  BE  PLOTED. 

-  REAL  :  Y  COORDINATE  USED  TO  CALCULATE  DISTANCE  F 

THE  YBASE. 


OUTPUTS  : 
NONE. 


VARIABLE  DICTIONARY  : 


CCNT 

X 

Y 


•  INTEGER  :  COUNTER  FOR  PRESENT  CONTOUR  LEVEL. 

■  REAL  :  X  COORDINATE  IN  INCHES. 

•  REAL  :  Y  COORDINATE  IN  INCHES. 


CALLED  MODULES  : 


PLOT  •  (X,  Y,  PENSTATE);  PLOTS  A  STRAIGHT  LINE. 

X  •  REAL  :  X  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 

Y  ■  REAL  :  Y  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 

PENSTATE  •  INTEGER  :  STATUS  OF  THE  PEN,  (UP,  DOWN,  NEW  ORIG 

SYMBOL  (X,  Y,  SIZE,  STRING,  ANGEL,  NCHAR);  PLOTS  A  CHARACTER  STRIN 

SIZE  -  REAL  :  SIZE  OF  THE  CHARACTER  IN  INCHES. 

STRING  •  CHAR(*)  :  CHARACTER  STRING  TO  BE  PLOTTED. 

ANGEL  •  REAL  :  ANGEL  STRING  IS  TO  BE  PLOTTED  AT. 

NCHAR  -  INTEGER  :  NUMBER  OF  CHARACTERS  TO  BE  PLOTTED. 

NUMBER  (X,  Y,  SIZE,  HUM,  ANGEL,  DPLACE);  PLOTS  A  NUMBER. 

NUM  •  REAL  :  NUMBER  TO  BE  PLOTTED. 

DPLACE  ■  INTEGER  :  NUMBER  OF  DECIMAL  PLACES  TO  BE  PLOTTED 


CALLING  MOOULE  : 


SCRPA0O 

SUBROUTINE  WHICH  ACTS  AS  A  DRIVER  FOR  THE  SCRATCH  PAD  PLOTS 


SUBROUTINE  PLOTITCXPLT,  YPLT,  JPTR,  XTEMP,  YTEMP,  XBASE,  YBASE, 
♦  AR,  CONVAL,  FTS,  SCALE,  SCRPSF,  NEWPLT) 


DECLARATION  OF  SUBROUTINE  INPUT/OUTPUT  VARIABLES. 

REAL  XPLT ( 1500) ,  YPLT(1500>,  AR,  CONVAL,  XBASE,  YBASE,  XTEMP 

REAL  YTEMP 

INTEGER  JPTR 

LOGICAL  SCRPSF,  NEWPLT 

DECLARATION  OF  SUBROUTINE  DEPENDANT  VARIABLES. 

REAL  X,  Y,  SCALE 

INTEGER  CCNT 

SAVE  CCNT 

IF  THE  SLOPE  IS  POSITIVE  THEN  PLOT  THIS  CONTOUR  LEVEL. 

IF  (NEWPLT)  THEN 
CCNT  «  0 
NEWPLT  *  .FALSE. 

END  IF 

IF  (FTS  .GE.  1.0)  THEN 

X  =  ((XPLT(1)  •  XTEMP)/SCALE)  ♦  XBASE 
Y  =  ( (YPLT ( 1 )  -  YTEMP)/$CALE)  ♦  YBASE 
CALL  PLOT(X,  Y,  3) 

•  DO  10,  I  a  1,  JPTR 

X  a  ((XPLT(I)  -  XTEMP)/SCALE>  ♦  XBASE 

Y  a  ( (YPLT ( I )  •  YTEMPJ/SCALE)  +  YBASE 

CALL  PLOT(X,  Y,  2) 


CONTINUE 


ELSE 

X  ■  ((XPLT(1)  -  XTENP)/SCALE) 

Y  *  ((YPLT(1)  -  YTEHP)/SCALE) 

Y1  ■  Y 

Y  ■  X  •  (-1)  ♦  YBASE 
X  ■  Y1  ♦  XBASE 

CALL  PLOT(X,Y,3) 

DO  20,  I  *  1,  JPTR 

X  »  (<XPLT<I>  -  XTEMP) /SCALE) 

Y  «  ((YPLT(I)  -  YTEMP)/SCALE) 

Y1  *  Y 

Y  *  X  *  (-1)  ♦  YBASE 
X  *  Yl  +  XBASE 

CALL  PL0T(X,Y,2) 

CONTINUE 

ENOIF 

CALCULATE  WHICH  CONTOUR  LEVEL  IT  IS. 

IF  (CCNT  .EQ.  3)  THEN 
CCNT  «  1 
ELSE 

CCNT  »  CCNT  ♦  1 
ENO  IF 

Y  *  0.6  •  (CCNT  *  .2) 

PLOT  THE  AREA  OF  THE  CONTOUR  THAT  WAS  JUST  PLOTED. 

IF  (CCNT  .EO.  1)  THEN 
IF  (SCRPSF)  THEN 

CALL  SYMBOL(0.6,Y,.09, 'AREA  OF  PSF  CONTOUR  LEVEL 

♦  0.0,36) 

CALL  SYNBOL(4.6,Y,.09,'SO.  NILES' ,0.0,9) 

ELSE 

CALL  SYMBOL(0.6,Y, .09, 'AREA  OF  DB  CONTOUR  LEVEL 

+  0.0,36) 

CALL  SYNBOL(4.6,Y, .09, 'SO.  NILES' ,0.0,9) 

ENOIF 

ENOIF 

IF  (CCNT  .EO.  2)  THEN 
IF  (SCRPSF)  THEN 

CALL  SYNBOL ( 0 . 6 , Y , . 09 , ' AREA  OF  PSF  CONTOUR  LEVEL 

♦  0.0,36) 

CALL  SYN80L(4.6,Y, .09, 'SO.  NILES' ,0.0,9) 

ELSE 

CALL  SYNBOL(0.6,Y, .09, 'AREA  OF  DB  CONTOUR  LEVEL 

♦  0.0,36) 

CALL  SYMBOL (4.6,Y,,09, ' SQ .  NILES' ,0.0,9) 

ENOIF 
END  IF 

IF  (CCNT  .EO.  3)  THEN 
IF  (SCRPSF)  THEN 
CALL  SYN80L(0.6,Y, .09, 'AREA  OF 

♦  0.0,36) 


PSF  CONTOUR  LEVEL 


CALL  SYM80L<4.6,Y, .09, 'SO.  NILES' ,0.0,9) 

ELSE 

CALL  SYMBOL  CO. 6, Y,. 09, 'AREA  OF  '  OB  CONTOUR  LEVEL 

♦  0.0,36) 

CALL  SYM80L(4.6,Y, .09, 'SO.  MILES' ,0.0,9) 

END  IF 
END  IF 

CALL  NUMBER  (1 .35, Y, .09,CONVAL,0.0,2) 

CALL  NUMBER  (3.8.Y,  .09, AR, 0.0, 4) 

RETURN 

END 

END  OF  SUBROUTINE  PLOTIT. 


»•*•*«••*••«••*•»*«•*•••  SUBROUTINE  CLSPLT  *•*»•*«*•*»*•»*»*•»•**•*•**• 
*«*****•«««*«*******•«** **♦#•#•********»»»****#********»****••*«**•»*»** 


MOOULE  NAME  :  CLSPLT 
MODULE  TYPE  :  SUBROUTINE 

PROGRAMMER  :  THOMAS  REILLY 
DATE  :  JANUARY  5,  1986 

REVISIONS  : 

DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  MOVE  TO  THE  NEXT  PLOT  P 


CABLED  MODULES  : 


PLOT  (X,  Y,  PENSTATE);  SKIPS  TO  THE.  NEXT  PLOT  PAGE. 

X  •  REAL  :  X  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 
Y  •  REAL  :  Y  COORDINATE  ON  PLOT  PAGE  IN  INCHES. 
PENSTATE  •  INTEGER  :  SKIPS  TO  THE  NEXT  PLOT  PAGE. 


CALLING  MOOULE  : 


SCRPADO  •  SUBROUTINE  TO  DRIVE  THE  SCRATCH  PAD  PLOTING. 


SUBROUTINE  CLSPLT 
CALL  PLOT(Q. ,0. ,999) 
RETURN 
END 

END  OF  SUBROUTINE  CLSPLT. 


********** ************************** w*********************************** 


SUBROUTINE  CONPTS  •**•*•*•"*•*••****”*•**• 
***#*•****•***«*«•**•**•***#****»**•******»+*•*•***•»»**»#******»»**»»** 

*•  MOOULE  NAME  :  CONPTS 
*•  MOOULE  TYPE  :  SUBROUTINE 

*•  PROGRAMMER  :  HARRY  SEIDMAN 
*•  DATE  :  DECEMBER  1986 

*-  REVISIONS  :  APRIL  1987,  CHANGE  FOR  CONSISTENCY  WITH  NEW  TEST  DATA. 
*•  DESCRIPTION  : 

*-  THE  PURPOSE  OF  THIS  ROUTINE  IS  TO  CONNECT  ALL  THE 

*•  POINTS  AROUND  A  CONTOUR.  IT  IS  ASSUMMED  THAT  AT 

*•  ANY  TIME  HACK  UP  TO  FOUR  POINTS  ON  THE  CONTOUR 

*•  MAY  EXIST. 

*•  MOOULE  I/O  : 


INPUTS  : 

IPTS  •  INT(IOOO)  :  NUMBER  OF  PTS  FROM  EACH  TIME  HACK  ACCUIR 

NTH  •  INTEGER  :  NUMBER  OF  TIME  HACKS. 

OUTPUTS  : 

IPATH  •  INT(IOOO)  :  THE  PATH  TO  CONECT  THE  CONTOUR  PTS. 

JPTR  -  INTEGER  :  NUMBER  OF  PTS  IN  IPATH. 


VARIABLE  DICTIONARY  : 


CALLED  MOOULES  :  NONE. 


CALLING  MOOULE  : 


SCRPAO  -  SUBROUTINE  THAT  DRIVES  THE  SCRACHPAD  PLOTTING  ROUTINE 


SUBROUTINE  CONPTSC IPTS , NPTS , IPATH , JPTR ) 


PARAMETER  (MAXPTS  *  1500) 
DIMENSION  IPTS(NPTS) 
DIMENSION  IPATH(MAXPTS) 
DIMENSION  I SUMPTS( MAXPTS) 


IF(  NPTS  .CT.  MAXPTS)  THEM 

PS  I NT  •,  'MUST  INCREASE  THE  DIMENSION  OF  ISUMPTS  IN', 

1  'SUBROUTINE  CONPTS' 

STOP 
END  IF 

»•  IF  ONLY  ONE  TIME  HACK  JUST  CONNECT  THE  POINTS 
IF(NPTS  .EO.  1)  THEN 
DO  20  I  «  1,  IPTS(I) 

IPATH<I)  «  I 
20  CONTINUE 

JPTR  »  IPTS(1) 

RETURN 
END  IF 

JPTR  *  1 

•-  DETERMINE  THE  TOTAL  NUMBER  OF  POINTS  THAT  EXIST  BEFORE  EACH  TIME  H 
ISUMPTSO)  ■  0 
DO  100  I  ■  2,  NPTS 

ISUMPTSO )  «  ISUMPTS(l-l)  ♦  IPTSO-1) 

100  CONTINUE 
GOTO  400 

120  CONTINUE 

••  CONNECT  UP  THE  LEFT  SIDE  OF  THE  CONTOUR 
DO  200  I  »  1,  NPTS 

IPATH(JPTR)  *  ISUMPTSO)  ♦  IPTSO ) 

JPTR  *  JPTR  *  1 
200  CONTINUE 


*•  CONNECT  THE  BOTTOM  OF  THE  CONTOUR 
IF  (  IPTS(NPTS)  .EO.  1  )  RETURN 
DO  250  I  *  2,  IPTS(NPTS) 

IPATH(JPTR)  ■  ISUMPTS(NPTS)  ♦  IPTS(NPTS)  •  (1-1) 
JPTR  ■  JPTR  *  1 
250  CONTINUE 

JPTR  «  JPTR  -  1 
RETURN 


*-  CONNECT  UP  THE  RIGHT  SIDE  OF  THE  CONTOUR. 
400  CONTINUE 

IPATH(JPTR)  »  ISUMPTS(NPTS)  ♦  1 
JPTR  «  JPTR  ♦  1 
OO  500  I  =  NPTS -1, 1,-1 

IPATH(JPTR)  =  ISUMPTSO)*1 
JPTR  *  JPTR  ♦  1 
500  CONTINUE 

*•  CONNECT  UPU  THE  TOP  OF  THE  CONTOUR. 

DO  550,  I  *  2,(1 SUMPTS(2) • 1 ) 


lPATH(JPTR)  *  I 
JPTR  ■  JPTR  ♦  1 
550  CONTINUE 
GOTO  120 
ENO 


I 


r****-***«**»****************  SUBROUTINE  SCRHFL  ******'*'* •■a*'********’ 

r«*«*«***««*'******'***‘**«Hk************'*  *-*•*'*■*-***«*'*«*'***  *«*****«***i 


-  MOOULE  NAME  : 

-  MOOULE  TYPE  : 

•  PROGRAMMER  : 

-  DATE  : 

-  REVISIONS  : 

-  DESCRIPTION  : 

THIS  SUBROUTINE  HAS  BEEN  DESIGNED  TO  CREATE  A  TEMPORAR 
FILE  WHICH  CONTAINS  THE  CAUSTIC  RAY'S  WHICH  HAVE  NOT  HAD 
A  SCRATCH  PAD  CREATED  FOR  THEM.  THIS  SUBROUTINE  ALSO  CALLS 
THE  SUBROUTINE  SORTRY,  WHICH  SORTS  THE  RAYS  ON  THE  PHI  ANGL 


SCRHFL 

SUBROUTINE 

THOMAS  REILLY 
DECEMBER  10,  1986 


MOOULE  I/O  : 

SCRHFL 

(SREC,  NREC,  SOPR,  NOPR) 

INPUTS  : 

NOPR 

•  INTEGER 

:  NUMBER  OF  OVERPRESSURE 

RECORDS. 

NREC 

-  INTEGER 

;  NUMBER  OF  RAYS  IN  THE 

FLIGHT  SEGMENT. 

SOPR 

■  INTEGER 

:  STARTING  RECORD  OF  THE 

OVERPRESSURE  RECOR 

SREC 

•  INTEGER 

:  STARTING  RECORD  OF  THE 

FLIGHT  SEGMENT. 

OUTPUTS  :  THE  OUTPUTED  FILE  FOR  THE  SCRATCH  PAD  PLOTS,  \SCRHFL 1 


-  FILE/IO  DICTIONARY  : 


INFILE  •  THIS  FILE  IS  THE  RAY  OATABASE  FILE. 

OUTFL  -  THIS  IS  A  SEQUENTIAL  FILE  USE  TO  STORE  THE  SORTED  RA 

FOR  USE  BY  THE  SCRATCH  PAD  SUBROUTINE,  "SCRHFL" 
TEMPFL  -  THIS  FILE  IS  USED  TO  SORT  THE  ARRAYS  ON  THE  PHI  ANGL 


VARIA8LE  DICTIONARY  : 


ARRL 

-  INTEGER 

:  NUMBER  OF  FIELDS  IN  THE  FILES. 

BUF 

•  CHAR (90) 

:  USED  TO  TRANSFER  AN  ENTIRE  RECORD  FROM  ON 

TO  ANOTHER. 

CAST  I C 

•  LOGICAL 

:  TRUE  IF  A  CAUSTIC  RAT  HAS  SEEN  FOUND. 

CTIME 

•  REAL 

:  CONTAINS  A  RAY  TERMINATION  TIME,  USED  TO 

FLIGHT  SEGMENTS  WITHIN  A  FLIGHT  TRACK. 

EREC 

•  INTEGER 

:  RECORD  NUMBER  OF  LAST  RAY  IN  FILE. 

ETIME 

•  PEAL 

:  ENDING  TIME  OF  THE  FLIGHT  SEQMENT . 

INFILE  -  INTEGER  :  FILE  NUMBER  OF  THE  RAY  DATABASE  FILE. 


K 

•  INTEGER 

LOOP  CONTOL  COUNTER. 

NPCNT 

•  INTEGER 

NUMBER  OF  CAUSTIC  FLIGHT  SEGMENTS  INCOUNT 

OUTFL 

•  INTEGER 

FILE  NUMBER  OF  THE  FILE  “SCRHFL'' . 

RAYS 

-  REAL C 1 1 ) 

ARRAY  TO  TRANSFER  THE  DATA  FROM  ONE  FILE 

ANOTHER. 

RECNT 

•  INTEGER 

RECORD  COUNTER  FOR  A  DIRECT  ACCESS  FILE. 

SCHCNT 

-  INTEGER 

RECORD  COUNTER  FOR  A  DIRECT  ACCESS  FILE. 

ST  I  ME 

•  REAL 

STARTING  TIME  OF  THE  FLIGHT  SEGMENT. 

TEMPFL 

•  INTEGER 

FILE  NUMBER  OF  THE  FILE  USED  TO  SORT  THE 

CALLING  MCOULES  : 


CONTURQ 

DRIVER  FOR  THE  PLOTING  AND  CONTOUR  ROUTINES. 


CALLED  MCOULES  : 


SRTRAY  (SCHCNT ,  TEMPAR,  SRTFLD)  :  SORTS  ARRAY  TEMPAR  WITH  SCHCNT 

NUMBER  OF  RECORDS  ON  SORTFLD . 
SRTFLD  -  INTEGER  :  FIELD  THE  DATA  IS  TO  BE  SORTED  ON. 


SUBROUTINE  SCRHFLISREC,  NREC,  SOPR,  NOPR,  ACTAIL,  SCRALL, 
1  TEMPAR) 


DECLARATION  OF  SUBROUTINE  INPUT/OUTPUT  VARIABLES. 

INTEGER  SREC,  NREC,  SOPR,  NOPR 

LOGICAL  SCRALL 

DECLARATION  OF  SUBROUTINE  DEPENDANT  VARIABLES. 

INTEGER  SCHCNT,  INFILE,  OUTFL,  TEMPFL,  ARRL ,  K,  EREC,  RECNT 

PARAMETER  < INFI LE=52,  OUTFL=32,  TEMPFl=33,  ARRL  =  11) 

INTEGER  NPCNT ,  RTYPE 

CHARACTERS  00  SUF 
CHARACTER*"  ACTAIL 
LOGICAL  CAST  1C,  FRECFL 

REAL  RAYS(ARRL) ,  CTIME,  ETIME,  ST  I  ME,  MAXOP,  TTIME 

DIMENSION  TEMPARIARRL, 1000) 

INITIALIZE  FILE  COUNTER  VARIABLES. 

RECNT  =  SREC  +  1 

SCHCNT  =  1 

CTIME  =  0.0 

EREC  *  (SREC  ♦  NREC) 

NPCNT  =  SOPR 
CASTIC  =  .FALSE. 


FRECFL  *  .FALSE. 

NOPR  «  (NOPR  ♦  SOPR)  •  1 
TTIME  »  0.0 
STIME  «  0.0 

LOOP  UNTIL  END  OF  THE  FLIGHT  TRACK. 

CONTINUE 

IF  (RECNT  .LE.  EREC)  THEN 

READ  (INFILE,  15,  REC=RECNT)  RTYPE, (RAYS( I ),  I=1,ARRL) 

FORMAT  <12,  F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 

RECNT  *  RECNT  +  1 
IF  (RTYPE  .EO.  00)  THEN 
GOTO  10 
ENO  IF 

IF  (CTIME  .EQ.  0.0)  THEN 
CT1ME  *  RAYS(1) 

END  IF 

IF  (STIME  .EO.  0.0)  THEN 
STIME  *  RAYS<1) 

END  IF 

IF  (TTIME  -EO.  0.0)  TTIME  »  RAYS<1) 

CHECK  IF  THE  CAUSTIC  RAY  HAS  A  TIME  DIFFERENCE  GREATER  THAN  4.5 
IF  ((RAYS(1)  •  TTIME)  .LT.  4.5)  THEN 

UPOATE  THE  DATABASE  THAT  THE  RAY  HAS  BEEN  PLOTTED. 

IF  (RTYPE  .EQ.  21)  CASTIC  *  .TRUE. 

IF  ((RTYPE  .EQ.  12)  .AND.  (SCRALL))  CASTIC  =  .TRUE. 

IF  (RTYPE  .EQ.  21)  RTYPE  *  12 
IF  (RTYPE  .EQ.  01)  RTYPE  *  01 

URITEONF1LE,  15,  REC=(RECNT- 1 ))  RTYPE ,  (RAYS(  I ) ,  I  =  1,ARRL) 

IF  IT'S  THE  FIRST  UNPLOTTED  CAUSTIC  RAY  THEN. 

IF  ((.NOT.  FRECFL)  .ANO.  (CASTIC))  THEN 
READ  (INFILE,  FMT=' (A) ' ,  REC=SREC)  8UF 
WRITE(BUF(48:49),FMT*'(A2)')  '  • 

WRITE(BUF(50:57),FMT»‘(A8)‘)  ACTA I L 
URITE(OUTFL,FMT*‘(A)')  SUF 
FRECFL  *  .TRUE. 

END  IF 

APPEND  THE  CAUSTIC  RAY  TO  TEMPAR. 

TTIME  *  RAYS<1) 

DO  18,  1=  1.ARRL 

TEMPAR ( I ,SCHCNT)  =  RAYS(I) 

CONTINUE 

SCHCNT  =  SCHLNT  +  1 

.  IF  (CTIME  .NE.  RAYS(D)  THEN 
SCHCNT  *  SCHCNT  ■  2 
RECNT  *  RECNT  ■  1 
IF  (SCHCNT  .GT.  1)  THEN 


CALL  SORTRY(SCXCNT,  TEMPAR,  8) 

END  IF 

APPEND  THE  SORTED  RAYS  TO  A  SEQUENTIAL  ACCESS  FILE. 
DO  20  I  *  1,  SCHCNT 

WRITE(34,25)  (TEMPAR(K,  I ) ,  K*1,ARRL) 

CONTINUE 

FORMAT  (F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 
SCHCNT  *  1 
CTIKE  *  0.0 
SO  TO  10 
ENOIF 

CTIME  *  RAYS(1) 

CO  TO  10 

IF  TIME  DIFFERENCE  IS  GREATER  THAN  4.5*. 

ELSE 

FRECFL  =  .FALSE. 

TTIME  *  0.0 
ETIME  =  CTIME 
CTIME  •  0.0 

IF  (.NOT.  CASTIC)  THEN 
SCHCNT  «  1 
REWIND<34) 

STIME  «  0.0 
GO  TO  10 
END  IF 

CASTIC  *  .FALSE. 

SORT  THE  RAYS  ON  PHI  ANGLE. 

RECNT  =  RECNT  -1 
SCHCNT  *  SCHCNT  -  1 
IF  (SCHCNT  .GT.  1)  THEN 
CALL  SORTRY(SCHCNT,  TEMPAR,  8) 

END  IF 

APPEND  THE  SORTED  RAYS  TO  A  SEQUENTIAL  ACCESS  FILE. 

DO  30  1  *  1,  SCHCNT 

WR!TE(34,25)  (TEMPAROC, I ),  K=1,ARRL) 

CONTINUE 
SCHCNT  *  1 

REWIN0(34) 

REA0(34,25,EN0*34)  (RAYS(I),  I=1,ARRL> 

WR1TE(0UTFL,25)  (RAYS(I),  I  =  1 ,ARRL) 

GOTO  32 

CONTINUE 

REWINDL34) 

WRITE  '88.0'  TO  THE  SEQUENTIAL  ACCESS  FILE. 

WRITE  (OUTFL , FMT  =  ' (A) ' )  '88.0' 

SEEK  THE  MAX  OVERPRESSURE  AND  WRITE  IT  TO  THE  FILE. 
MAXOP  *  -999999. 


R£AD( INFILE, FMTa‘ (A) 1 ,  REC*NPCNT)  BUF 
READ(8UF(52:61),FMTa<(F10.4>'>  CUROP 
READ ( BUF (1 :8), FMTa‘ (F8.2) 1 )  CURTIM 

IF  ((CURTIM  .GE.  STIME)  .AND.  (CURTIM  .LE.  ETIME))  THEN 
IF  (CUROP  .GT.  MAXOP)  THEN 
MOPREC  »  NPCNT 
MAXOP  «  CUROP 
END  IF 

NPCNT  *  NPCNT  ♦  1 
IF  (NPCNT  .LE.  NOPR)  THEN 
GOTO  35 
END  IF 
END  IF 

READ(INFILE,FMT*' (A) ' ,REC=MOPREC)  BUF 
URITE£OUTFL,FMTa<(A)')  BUF 
STIME  -  0.0 
GO  TO  10 
ENO  IF 
END  IF 

IF  SCRCHCNT  GREATER  THAN  ONE  THAN 

IF  ( (SCHCNT  .GT.  1)  .AND.  ( CAST  I C  3 }  THEN 

ETIME  «  CTIME 

CTIME  a  0.0 

SCHCNT  a  SCHCNT  •  1 

IF  (SCHCNT  .GT.  1)  THEN 

CALL  SORTRY( SCHCNT,  TEMPAR,  8) 

END  IF 

APPEND  THE  SORTED  RAYS  TO  A  SEQUENTIAL  ACCESS  FILE. 

DO  50  I  a  1,  SCHCNT 

WRITE{34,25)  (TEMPAR(K, I ),  K=1,ARRL) 

CONTINUE 

REUIN0(34) 

READ(34,25,EN0a54)  (RAYS(I),  I=1,ARRL> 

URITE(OUTFL,25)  (RAYS(I),  I  a  1.ARRL) 

GOTO  52 

CONTINUE 

REWIN0(34) 

SORT  LAST  SCRCH  PAD  AND  WRITE  '88.0'  TO  OUTF1LE. 

WRITE  (OUTFL,FMTa'(A)')  '88.0' 

SEEK  THE  MAX  OVERPRESSURE  AND  WRITE  IT  TO  THE  FILE. 

MAXOP  a  -999999. 

READ( INFILE, FMT  = 1 ( A) ' ,REC=NPCNT )  BUF 
REA0(8UF( 52:61 ) , FMTa 1 ( F10.4) ' )  rilPOP 
R£AD(8UF( t :8 ) , FMTa  ‘ ( F8 . 2) 1 )  CURTIM 

IF  ((CURTIM  .GE.  STIME)  .AND.  (CURTIM  .LE  ETIME))  THEN 
IF  (CUROP  .GT.  MAXOP)  THEN 
MOPREC  a  NPCNT 
MAXOP  a  CUROP 


END  IF 

NPCNT  *  NPCNT  ♦  1 
IF  (NPCNT  .LE.  NOPR)  THEN 
GOTO  55 
END  IF 
END  IF 

READ( INFILE, FMT*1 (A) ‘ ,REC=MOPREC)  BUF 
WRITE(OUTFL, FHT*1 (A) 1 )  BUF 
END  IF 

CONTINUE 

END  OF  THE  SUBROUTINE  SCRCHFL. 

RETURN 

END 

END  OF  SUBROUTINE  SCRCHFL. 


***#*•#***%  l******************************************************'******* 


...«M.....*»t....>«MtM  SUBROUTINE  SORTRY 


*-  MODULE  NAME  :  SORTRY 

*-  MOOULE  TYPE  :  SUBROUTINE 

*•  PROGRAMMER  :  THOMAS  REILLY 

*-  DATE  :  DECEMBER  1,  1986 

*•  DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  SORT  AN  IMPUTED  ARRAY 
USE 1 NG  A  HEAP  SORT  METHOO  ON  A  SEPECIFIED  SORT  FIELD. 


*-  VARIABLE  DICTIONARY  : 


TEMPAR  -  ARRAY  OF  RAY'S  TO  BE  SORTED  ON  TERMINATION  TIME. 

TRAY  •  TEMPORARY  VARIABLE  TO  HOLD  AN  ELEMENT  OF  THE  RAY  DATA  UH 
IT  IS  BEING  SWITCHED  WITH  ANOTHER  ELEMENT. 

NREC  •  NUMBER  OF  RECORDS  IN  THE  SEGMENT  TO  BE  SORTED. 

SREC  •  STARTING  RECORD  OF  THE  SEGMENT. 

OFFSET  •  OFF  SET  BETWEEN  THE  ARRAY  AND  STARTING  RECORD  OF  THE  SEG 
I , J , K, L  •  COUNTERS  USED  TO  MINIPULATE  THE  ARRAY. 

IR  •  COUNTER  USED  TO  MINIPULATE  THE  RAY  ARRAY. 


*•  CALLING  MOOULE  : 


SCRHFL  •  SUBROUTINE  THAT  CREATES  THE  SCRCHPAD  FILE. 


*•  CALLED  MOOULE  :  NONE. 


* . 


SUBROUTINE  SORTRYINPTS, TEMPAR , SRTFLD ) 


INTEGER  NPTS,  I,  J,  K,  L,  ARRL,  SRTFLD 

PARAMETER  (ARRL  =11) 

REAL  TRAY (ARRL ) 

REAL  TEMPAR(ARRL, 1000) 

SET  UP  INITIALIZATION  FOR  HEAPSORT. 

L  =  NPTS  /  2  +  1 


IR  3  NPTS 


*•  HEAP  CREATION  PHASE. 

30  CONTINUE 

IF  CL  .GT.  1)  THEN 
L  3  L  •  1 

*-  INITIALIZE  RRA  TO  ELEMENT  RACL)  IN  THE  RAY  ARRAY. 

00  32,  K  •  1,  ARRL 

TRAYCK)  «  TEMPARCK, L) 

32  CONTINUE 

ELSE 

*-  PLACE  TOP  OF  HEAP  AT  THE  END  OF  THE  ARRAY. 

DO  34,  K  ■  1.ARRL 

TRAY  00  3  TEMPARCIC,  IR) 

TEMPARCK, IR)  3  TEMPARCK, 1) 

34  CONTINUE 

IR  3  IR  -  1 

*•  PLACE  SMALLEST  ELEMENT  AT  THE  BEGIN  I NG  OF  THE  ARRAY. 

IF  (IR  .EQ.  1)  THEN 

DO  36,  K  *1 , ARRL 

TEMPARCK, 1)  3  TRAYCK) 

36  CONTINUE 

*•  EXIT  LOOP  ANO  WRITE  ARRAY  BACK  INTO  THE  RAY  FILE. 

GO  TO  100 
END  IF 
END  IF 
I  3  L 
J  3  L  +  L 

*•  SET  UP  TO  SHIFT  DOWN  SLMENT  RRA  TO  ITS  PROPER  LEVEL 
70  IF  (J  .LE.  IR)  THEN 

IF  (J  ,LT.  IR)  THEN 

*•  COMPARE  THE  RAY  TERMINATION  TIMES. 

IF  (TEMPARCSRTFLD, J)  .LT.  TEMPARCSRTFLD, CJ+1 ) ))  J  3  J  +  1 
ENOIF 

*-  COMPARE  THE  RAY  TERMINATION  TIMES. 

IF  (TRAY(SRTFLD)  .IT.  TEMPAR { SRT FLD , J ) )  THEN 
DO  72,  K=1 ,ARRL 

TEMPARCK, I)  3  TEMPARCK, J) 

72  CONTINUE 

I  3  J 
J  3  J  ♦  J 
ELSE 

*-  THIS  IS  RRA'S  LEVEL.  SET  J  TO  TERMINATE  SHIFT  DOWN 

J  3  IR  ♦  1 


ENOIF 


*•  LOOP  WHILE  J  LESS  THAN  OR  EQUAL  TO  IR. 

GO  TO  70 
END  IF 

*•  PUT  RRA  INTO  ITS  SLOT. 

DO  74,  IC*1,ARRL 

TEMPAR(K,  I )  *  TRAYOC) 

74  CONTINUE 

*-  LOOP  UNTIL  ARRAY  IS  SORTED. 

GO  TO  30 

100  CONTINUE 

RETURN 
ENO 


r************«*«*******#********«*******-**********»***»********** 


*****************************  SUBROUTINE  DIVARR  ***************' 

****»««*«****»*»**»i>**«»***»**  *»»»*»*♦♦«*«»♦»**»♦»»*»*»»»»»*»♦■ 

•  MOOULE  NAME  :  DIVARR 

-  MOOULE  TYPE  :  SUBROUTINE 

-  PROGRAMMER  :  THOMAS  REILLY 

-  DATE  :  DECEMBER  17,  1986 

•  REVISIONS  : 

•  DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  ACCEPT  A  SCRATCH  ARRAY, 
A  SCRATCH  COUNTER  ARRAY,  AND  A  SARR  ARRAY.  THIS  SUBROUTINE 
THEN  DIVIDES  THE  SCRATCH  ARRAY  BY  THE  COUNTER  ARRAY  AND 
ENTERS  IT  INTO  THE  MASTER  ARRAY,  WHEN  4.5  SECONDS  HAS 
ELAPSED  BETWEEN  RAYS  OR  IT  THE  END  OF  A  FLIGHT  SEGMENT. 


MOOULE  I/O  :  DIVARR  (MASTER,  SCRCNT,  SCRCH) 


INPUTS  : 

MASTER  •  REAL(102, 102)  :  MASTER  ARRAY  CONTAINING  THE  POWER  VAL 
SCRCNT  •  INTC102, 102)  :  COUNTER  ARRAY  OF  THE  NUMBER  OF  RAYS  T 

HIT  A  GRID  POINT. 

SCRCH  •  REAL(102, 102)  :  SCRATCH  PAD  FOR  THE  RAY  POWERS  AT  EAC 

GRID  POINT. 

OUTPUTS  :  THE  MASTER  ARRAY  IS  RETURNED  WITH  SCRCH/SCRCNT  +  MASTER. 


VARIABLE  DICTIONARY  : 


I  -  INTEGER 

J  •  INTEGER 


:  LOOP  CONTROL  VARIABLES. 
:  LOOP  CONTROL  VARIABLES. 


CALLING  MODULES  : 


GRIDPW  (GRNDZ,  TEMPCT,  MASTER,  SCRCNT,  SCRCH)  ; 

THIS  SUBROUTINE  CALCULATES  THE  GRID  POWERS  AND  CREATES 
THE  ARRAYS  SCRCNT,  SCRCH. 


SUBROUTINE  DIVARR  (MASTER,  SCRCNT,  SCRCH) 


DECLARATION  OF  SUBROUTINE  INPUT /OUTPUT  VARIABLES. 

INTEGER  LOWBND,  UPBNO 

PARAMETER  (L0W8ND  ■  -51,  UPBNO  -  50) 

REAL  SCRCNT(LOUBNO:UPSND,  L0U8N0 :UPBND) 

REAL  MASTER! LOWBNO :UP8N0 ,  LOWBND: UPBNO),  SCRCH! LOWBNO : UPBNO , 
1  LOWBND :UPBND) 

DECLARATION  OF  SUBROUTINE  OEPENOANT  VARAIBLES. 

INTEGER  1,  J 

DIVIDE  THE  SCRATCH  ARRAY  BY  THE  SCRATCH  COUNTER  ARRAY. 

ENTER  THE  VALUE  INTO  THE  MASTER  ARRAY. 

DO  20  J  *  LOWBNO,  UPBNO 
DO  10  I  a  LOWBNO,  UPBNO 

IF  (SCRCNT(I.J)  .HE.  0)  THEN 

MASTER! I , J)  «  MASTER! I , J)  ♦  !SCRCH!1,J)  /  SCRCNT!I,J)) 
SCRCH! I , J )  <  0.0 
SCRCNT ! I , J )  ■  0 
END  IF 
CONTINUE 
CONTINUE 
RETURN 
ENO 

END  OF  SUBROUTINE  OIVARR. 


***»*»»**•»*»»••**••»»****»♦»  SUBROUTINE  GRIDPW 


MODULE  NAME  :  GRIDPW 
MOOULE  TYPE  :  SUBROUTINE 

PROGRAMMER  :  THOMAS  REILLY 
DATE  :  NOVEMBER  20,  1986 

REVISIONS  : 

DESCRIPTION  : 

THIS  SUBROUTINE  IS  DESIGNED  TO  ACCEPT  X,  Y,  2  POINTS  0 
WHERE  A  RAY  LEAVES  THE  AIRCRAFT,  X,Y,  Z  POINTS  AND  TIME  OF 
WHERE  THE  RAY  TERMINATES,  AND  THE  PRESSURE  OF  THE  RAY.  THE 
SUBROUTINE  THEN  CALCULATES  THE  SLANT  DISTANCE  BETWEEN  THE  R 
TERMINATION  AND  THE  A/C,  THE  SLANT  DISTANCE  BETWEEN  THE  FOU 
SUROUNOING  GRIOPOINTS  ANO  THE  A/C,  WEIGHTS  AT  THE  FOUR  GRID 
POINTS,  POWERS  AT  EACH  GRID  POINT,  AND  THEN  PRESENTS  A  SCRA 
ARRAY  OF  POWERS,  A  COUNTER  SCRATCH  ARRAY  OF  THE  NUMBER  OF  R 
AT  EACH  GRID  POINT.  IT  THEN  CALLS  DIVARR  TO  CALCULATE  THE  M 
ARRAY.  THE  SCRATCH  ARRAYS  ARE  FOR  A  FLIGHT  SEGMENT  OR  ELAP 
TIME  OF  A. 5  SECOUNDS  BETWEEN  RAYS.  THE  MASTER  ARRAY  IS  FO 
ENTIRE  FLIGHT  TRACK. 


MOOULE  I/O  :  GRIDPW  (GRNDZ,  TEMPCT ,  MASTER,  SCRCNT,  SCRCH) 


INPUTS  :  INCLUDING  COMMON  BLOCKS. 

CONTYP  -  !NTGER<5)  :  TYPE  OF  CONTOURS  THE  USER  WANTS. 

FFT  •  LOGICAL  :  TRUE  IF  CSEL  LEVEL  IS  TO  BE  USED  ON  CONTO 

GRNDZ  •  REAL  :  Z  COORDINATE  OF  RAY  WHERE  IT  TERMINATES. 

TEMPCT  •  INTEGER  :  NUM8ER  OF  RECORDS  IN  THE  INPUT  FILE, 

OUTPUTS  :  INCLUDING  COMMON  BLOCKS. 

MASTER  -  REAL(102, 102)  :  MASTER  ARRAY  CONTAINING  POWER  OF  INTI 

FLIGHT  TRACK. 

LIMAXO  *  INTEGER  :  LOWER  LIMIT  OF  TH'i  X  INOICE  FOR  THE  GRID 

LIMAYO  •  INTEGER  :  LOWER  LIMIT  OF  THE  Y  INDICE  FOR  THE  GRID 

LIMAX1  •  INTEGER  :  UPPER  LIMIT  OF  THE  X  INDICE  FOR  THE  GRID 

LIMAY1  •  INTEGER  :  UPPER  LIMIT  OF  THE  Y  INDICE  FOR  THE  GRID 

THE  FOLLOWING  VARIA8LE  ARE  IMPUTED  AND  OUTPUTED  ONLY  TO  ALLOW 
THE  MEMORY  THEY  OCCUPY  TO  BE  EOUIVALANCED . 

SCRCH  •  REAL < 102, 102)  :  SCRATCH  ARRAT  CONTAINING  THE  POWERS  A 

EACH  GRID  POINT. 

SCRCNT  •  I  NT (102, 102)  :  COUNTER  OF  NUMBER  OF  RAYS  HITING  EACH 

GRID  POINT. 


FILE/IO  DICTIONARY  : 


I 


TEMPFL  •  TEMPORARY  FILE  CONTAINING  SORTED  RAYS. 


VARIABLE  DICTIONARY  : 


AIRT 

•  REAL 

AIRX 

-  REAL 

AIRY 

*  REAL 

AIRZ 

•  REAL 

ETIME 

-  REAL 

GRNOT 

•  REAL 

GRNOX 

-  REAL 

GRNOY 

•  REAL 

GSEC 

•  INTEGER 

POWERl 

■  REAL 

P0UER2 

•  REAL 

P0WER3 

•  REAL 

P0WER4 

•  REAL 

PRESS 

•  REAL 

RECNT 

•  INTEGER 

SLANT 

•  REAL 

SLANT 1 

•  REAL 

SLANT2 

•  REAL 

SLANT3 

•  REAL 

SLANT4 

•  REAL 

TIME 

•  REAL 

WGHT1 

•  REAL 

WGHT2 

•  REAL 

WGHT3 

•  REAL 

WGHT4 

•  REAL 

X,  Y 

•  INTEGER 

TIME  THE  RAY  LEAVES  THE  AIRCRAFT. 

X  COORDINATE  OF  RAY  WHERE  IT  LEFT  THE  A/C 

Y  COORDINATE  OF  RAY  WHERE  IT  LEFT  THE  A/C 

Z  COORDINATE  OF  RAY  WHERE  IT  LEFT  THE  A/C 

CONSTANT  OF  4.5,  DIFFERENCE  IN  SEOMENTS. 
TIME  THE  RAY  TERMINATES. 

X  COORDINATE  OF  RAY  WHERE  IT  TERMINATES. 

Y  COORDINATE  OF  RAY  WHERE  IT  TERMINATES. 

CONSTANT  WITH  THE  VALUE  OF  THE  GRID  SEGME 
POWER  OF  RAY  FOR  GRID  POINT  £I,J. 

POWER  OF  RAY  FOR  GRID  POINT  [1*1, JJ. 

POWER  OF  RAY  FOR  GRID  POINT  [I,J+1). 

POWER  OF  RAY  FOR  GRID  POINT  £1*1 , J*1] . 

PRESSURE  OF  THE  RAY  AT  TERMINATION. 
COUNTER  FOR  THE  RECORD  IN  THE  TEMPORARY  F 
SLANT  DISTANCE  BETWEEN  A/C  AND  RAY  TERM  IN 
SUNT  DISTANCE  BETWEEN  A/C  AND  GRID  POINT 
SLANT  DISTANCE  BETWEEN  A/C  AND  GRID  POINT 
SLANT  01 STANCE  BETWEEN  A/C  AND  GRID  POINT 
SLANT  DISTANCE  BETWEEN  A/C  AND  GRID  POINT 
CONTAIN  TIME  TO  CHECK  FOR  4.5  SECOUND  SEG 
WEIGHT  OF  RAY  FOR  GRID  POINT  £I,JJ. 

WEIGHT  OF  RAY  FOR  GRID  POINT  [1*1 ,J]. 

WEIGHT  OF  RAY  FOR  GRID  POINT  £I,J*1). 

WEIGHT  OF  RAY  FOR  GRID  POINT  £1*1, J+1]. 

TEMPORARY  VARIABLE  FOR  COMPUTING  GRID  POI 


CALLING  MOOULES  : 


CONTUR  (MASTER,  SCRCNT,  SCRCH)  ; 

THIS  SUBROUTINE  CREATES  THE  TEMPORARY  FILES  AND 
INVOKES  THIS  SUBROUTINE. 

CALLED  MOOULES  : 


DIVARR  (MASTER,  SCRCNT,  SCRCH) 

THIS  SUBROUTINE  DIVIDES  THE  SCRATCH  ARRAY  BY  THE  SCRATCH 
COUNTER  ARRAY  AND  ENTERS  IT  INTO  THE  MASTER  ARRAY. 


SUBROUTINE  GRIDPW  (GRNOZ,  TEMPCT,  MASTER,  SCRCNT,  SCRCH) 


DECLARATION  Of  SUBROUTINE  INPUT/OUPUT  VARIABLES. 

COMMON  /GRID/  GRDXO,  XGS,  GRDXMX,  GRDYO,  YGS,  GRDYMX, 

1  LIMAXO,  LI MAYO,  LIMBXO,  LIMBYO, 

2  LIMAX1,  LIMAY1 ,  LIMBX1,  LIMBY1 

COMMON  /STATS/  STATFL,  BOOMFL,  MACHFL,  CONTFL,  BOOMVA, 

+  MACHVA,  CONTVA,  CONTYP,  WIDTH,  FFT,  SIGNAT, 

♦  RAYTRA.SCRPAD,  SCRPSF,  SCRALL 

INTEGER  LOW8ND,  UPBND ,  LIMAXO,  LIMAYO,  LIMAX1 ,  LIMAY1 

PARAMETER  (LOWBNO  ■  -51,  UPBND  >  50) 

REAL  SCRCNT< LOWBNO: UPBND,  LOWBNO : UPBND ) 

INTEGER  CONTYP(5) 

REAL  MASTER ( LOWBNO : UPBND ,  LOW8ND: UPBND),  SCRCHCLOWBNO: 

1  UPBND,  LOWBNO :UP8ND),  CONTVAC5,  20),  MACHVA, 

2  WIDTH 

LOGICAL  FFT,  RAYTRA,  SIGNAT,  STATFL,  BOOMFL,  MACHFL, 

1  CONTFL 

DECLARATION  OF  SUBROUTINE  DEPENDANT  VARIABLES. 

INTEGER  GSEC,  WPOWER,  X,  Y,  RECNT,  TEMPCT 

REAL  ETIME,  PRESS,  SUNT,  SLANT1,  SLANT2,  SLANT 3, 

1  SLANT4,  WGHT1,  WGHT2,  WGHT3,  WGHT4,  POWER 1,  POWER2 

2  POWER3,  POWER4,  AIRX,  AIRY,  A1RZ,  GRNDX,  GRNDY, 

3  GRNDZ 

PARAMETER  (GSEC  *  2500,  WPOWER  *  3,  ETIME  a  5.5) 


TIME  =■  0.0 
RECNT  «  1 

READ  A  RAY  FROM  THE  TEMPORARY  FILE. 

CONTINUE 

IF  (RECNT  .LE.  TEMPCT)  THEN 

READ  (33,  15,  REC=RECNT)  AIRT,  AIRX,  AIRY,  AIRZ,  GRNDT, 

♦  GRNDX,  GRNDY,  TEMP2,  PRESS,  CSEL 

FORMAT  (F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  2F10.4) 

RECNT  *  RECNT  ♦  1 

IF  ((CONTYP(I)  .EQ.  1)  .AND.  (FFT)  .AND.  (CSEL  ,EQ.  0.0) 
1  .OR.  (CSEL  .ED.  -1.0))  GOTO  10 

AIRX  *  AIRX  /  0.3048 
AIRY  *  AIRY  /  0.3048 
AIRZ  *  AIRZ  /  0.3048 
GRNOX  *  GRNOX  /  0.3048 
GRNOY  =  GRNOY  /  0.3048 


CALCULATE  NEAREST  GRID  POINTS,  CHECK  THAT  RAYS  ARE  IN  80UNDS . 
X  *  !NT(GRN0X  /  GSEC) 

Y  -  I NT(GRN0Y  /  GSEC) 

IF  (TIME  .EQ.  0.0)  THEN 


TIME  *  GRNDT 
ENOIF 


CHECK  IF  RAY  IS  UlTHIH  GRID  SOUNDS. 

IF  (((X  .LE.  L0W8N0)  .OR.  <X  .GE.  UPSND)  .OR.  CY  .IE. 
L0W8ND )  .OR.  (Y  .GE.  UPBND > ) )  THEN 
GO  TO  10 
END  IF 


IF  ((GRNDT  -  TIME)  .LT.  ETIME)  THEN 

CALCULTATE  SLANT  DISTANCE  FROM  A/C  TO  RAY  TERMINATION. 
SLANT  ■  ( (AIRX  •  GRNDX)**  2.0  +  (AIRY  •  GRNDY)**  2.0  ♦ 
(AIRZ  -  GRNDZ)**  2.00)**  0.5 


CALCULATE  SLANT  DISTANCE  FROM  A/C  TO  4  SURROUNDING  GRID  POI 
SLANT1  *  ((AIRX  -  (X  *  GSEC))**2.0  ♦  (AIRY  •  ,(Y  *  GSEC)) 

**  2.0  ♦  (A1R2  •  GRNOZ)**  2.0)**  0.5 
SLANT2  *  ((AIRX  •  ((X+1)  *  GSEC))**  2.0  ♦  (AIRY  -  (Y  * 
GSEC))**2.0  ♦  (AIRZ  •  GRNDZ)**  2.0)**  0.5 
SLANT3  *  ((AIRX  •  (X  *  GSEC))**  2.0  ♦  (AIRY  •  ((Y+1)  * 
GSEC))**2.0  ♦  (AIRZ  •  GRNOZ)**  2.0)»*  0.5 
SLANT4  »  ((AIRX  •  ((X+1)  •  GSEC))**  2.0  ♦  (AIRY  -  ((Y  ♦ 

1)  *  GSEC))**  2.0  ♦  (AIRZ  -  GRNDZ)**  2.0)**  0.5 

CALCULATE  WEIGHTS  FOR  EACH  OF  THE  FOUR  GRID  POINTS. 

WGHT1  *  (SLANT  /  SLANT1 )**  WPOWER 
UGHT2  ■  (SLANT  /  SLANT2)**  WPOWER 
WGHT3  *  (SLANT  /  SLANT3)**  WPOWER 
WGHT4  =  (SLANT  /  SLANT4)**  WPOWER 

CALCULATE  THE  POWERS  OF  EACH  OF  THE  FOUR  GRID  POINTS. 

IF  ((CONTYP(I)  .EG.  1)  .ANO.  ( FFT) )  THEN 
POWER 1  *  WCHT1  *  (CSEL**  2.0) 

POWER2  *  WGHT2  *  (CSEL**  2.0) 

POWER3  *  WCHT3  *  (CSEL**  2.0) 

POWER4  *  WGHT4  *  (CSEL**  2.0) 

ELSE 

PUWER1  *  WCHT1  *  (PRESS**  2.0) 

POWER 2  *  WGHT2  *  (PRESS**  2.0) 

POWER3  *  WGHT3  *  (PRESS**  2.0) 

POWER4  =  WGHT4  »  (PRESS**  2.0) 

ENO  IF 

ADO  THE  POWERS  TO  THE  APPROPRIATE  SCRATCH  PAD  CEIL  AND  INCR 
THE  APPROPRIATE  SCRATCH  COUNTER  CELL. 

SCRCH(X,Y)  =  SCRCH(X.Y)  ♦  POWER  1 

SCRCH( (X* 1 ) , T )  *  SCRCH((X+1),T)  +  POWER2 

SCRCH(X , (Y+1 ) )  s  SCRCH(X, (Y+1 ) )  +  POWER3 

SCRCH( (X+1 ) , (Y+1 ))  i  SCRCH( (X+1 ) , (Y+1 ) )  +  POWER 4 


SCRCNT(X.Y)  *  SCRCNT(X.Y)  ♦  1 

SCRCNT ( (X*1 ) ,  Y)  *  SCRCNT( (X+1 ) , Y)  +  1 

SCRCNT(X,(Y+1))  *  SCRCNT (X , (Y+1 ) )  ♦  1- 

SCRCNT((X-M),(Y+1))  *  SCRCNT ( (X+1 ) , (Y+1 > )  ♦  1 

LIMAXO  =  MlNO(L IMAXO , (X+52) ) 

L1MAYO  =  HIN0(UMAY0,(Y»52)) 

LIMAX1  =  HAXO(LIMAX1 , (X*52) ) 

L1MAY1  *  MAX0(LIMAY1,(Y+52)) 

ELSE  IF  END  OF  FLIGHT  SEGMENT  OR  ELAPSED  TIME  GREATER  THAN  4.5 
ELSE 

IF  ( (GRNOT  -  TIME)  .GE.  ETIME)  THEN 
RECNT  *  RECNT  -  1 
ENOIF 

DIVIDE  SCRATCH  ARRAY  BY  COUNTER  SCRATCH  ARRAY  AND  ADD  RESUL 
TO  THE  MASTER  ARRAY. 

CALL  OIVARRC  MASTER,  SCRCNT,  SCRCH) 

TIME  *  0.0 
ENO  IF 

ENO  OF  LOOP. 

TIME  *  GRNDT 
GO  TO  10 
END  IF 

CALL  DIVARR(  MASTER,  SCRCNT,  SCRCH) 


RETURN 

ENO 

END  OF  SUBROUTINE  GRIOPOW. 


************************************************■•****<»***************** 

**************************  SUBROUTINE  SRTRAY  ************************** 
*********************************************************************** 

i 

•  MODULE  NAME  :  SRTRAY 

•  MODULE  TYPE  :  SUBROUTINE 

•  PROGRAMMER  :  THOMAS  REILLY 

•  DATE  :  DECEMBER  1,  1986 

•  REVISIONS  : 

-  DESCRIPTION  : 


THIS  SUBROUTINE  IS  DESIGNED  TO  SORT  THE  TEMPORARY  FILE 
TEHPFL,  ON  THE  RAY'S  TERMINATION  TIME.  THE  NUMBER  OF  RECOR 
TO  BE  SORTED,  IN  THE  FILE  TEMPFL,  IS  PASSED  INTO  THE  SUBROU 
THE  FILE  IS  THEN  SORTED  USING  A  HEAPSORT,  ON  TERMINATION  TI 


MOOULE  I/O  :  SRTRAY  (TEMPCT ,  INFILE,  SRTFLD) 


INPUTS  : 

INFILE  •  INTEGER  :  NUMBER  OF  THE  FILE  TO  BE  SORTED. 

TEMPCT  -  INTEGER  :  NUMBER  OF  RECORDS  IN  THE  SEGMENT  TO  BE  SO 

SRTFLD  -  INTEGER  :  FIELD  THE  FILE  IS  TO  BE  SORTED  ON. 

OUTPUTS  :  THE  SORTED  INPUT  FILE  INFILE. 


FILE/IO  DICTIONARY  : 


TEMPFL  •  DATA  FILE  THAT  CONTAINS  THE  RAY'S  START  POINTS,  END  P 
TERMINATION  TIMES,  AND  PRESSURE. 


VARIABLE  DICTIONARY  : 


I 

IR 

J 

K 

L 


-  INTEGER 

•  INTEGER 

-  INTEGER 

-  INTEGER 

•  INTEGER 


:  USED  TO  TRAVERSE  THE  ARRAYS  TO  SORT. 
:  USED  TO  TRAVERSE  THE  ARRAYS  TO  SORT. 
:  USED  TO  TRAVERSE  THE  ARRAYS  TO  SORT. 
:  LOOP  CONTROL  VARIABLE. 

:  USED  TO  TRAVERSE  THE  ARRAYS  TO  SORT. 


TRAY  -  REAL ( 1 1 ) 

TFAY2  •  TEAL(II) 

•  REAL  C  HD 


TEMPORARY  VARIABLE  TO  HOLD  AN  ELEMENT  OF 
DATA  WHILE  IT  IS  BEING  SWITCHED  WITH  ANOT 
TEMPORARY  VARIABLE  TO  HOLD  AN  ELEMENT  OF 
DATA  WHILE  IT  IS  BEING  SWITCHED  WITH  ANOT 
TEMPORARY  VARIA8LE  TO  HOLD  AN  ELEMENT  OF 
DATA  WHILE  IT  IS  BEING  SWITCHED  WITH  ANOT 


RAY3 


CALLING  MODULE 


CONTUR  (MASTER,  SCRCNT,  SCRCH) 

SUBROUTINE  WHICH  PASSES  THE  FILE  SEGMENTS  TO  BE  SORTED 
FROM  THE  SUBROUTINE  G£T_REC. 

SCRHFL  (SREC,  NREC,  SOPR,  NOPR) 

SUBROUTINE  WHICH  CREATES  THE  SCRATCH  PAD  FILE  FOR  UNPLOTT 
CAUSTIC  RAYS. 


SUBROUTINE  SRTRAY(TEMPCT,  INFILE,  SRTFID) 

*•  DECLARATION  OF  SUBROUTINE  INPUT/OUTPUT  VARIABLES. 
INTEGER  TEMPCT,  INFILE,  SRTFLD 

*•  DECLARATION  OF  SUBROUTINE  DEPENDANT  VARIABLES. 

INTEGER  I,  J,  X,  L,  ARRL 

PARAMETER  (ARRL  =11) 

REAL  TRAY (ARRL ) ,  TRAY2(ARRL),  TRAY3(ARRL) 

•-  SET  UP  INITIALIZATION  FOR  HEAPSORT. 

L  *  TEMPCT  /  2  ♦  1 
IR  *  TEMPCT 

*•  HEAP  CREATION  PHASE. 

30  CONTINUE 

IF  (L  .GT.  1)  THEN 
L  =  L  -  1 

*•  INITIALIZE  TRAY  TO  RECORD  L  IN  THE  PAY  FILE. 

READ  (INFILE,  120,  REC=L  >  (TRAY(K) ,  X=1,ARRL) 

ELSE 

*■  PLACE  TOP  OF  HEAP  AT  THE  END  OF  THE  FILE. 

READ  (INFILE,  120,  REC=JR  >  (TRAY(X),  X=1,ARRL) 

READ  (INFILE,  120,  REC=1  )  (TRAY2(K) ,  X=1,ARRL) 
WRITE  (INFILE,  120,  REC=IR  )  (TRAY2(X),  K=1 ,ARRL) 

IR  =  IR  ■  1 

*-  PLACE  SMALLEST  ELEMENT  AT  THE  BEGINING  OF  THE  FILE. 

IF  (IR  .EO.  1)  THEN 

WRITE  ( INFILE,  120,  R£C=1  )  (TRAY(X),  X=1,ARRL) 

•-  EXIT  LOOP  AND  RETURN  TO  CALLING  MOOULE. 

GO  TO  100 
END  IF 
END  IF 
I  *  L 
J  =  L  ♦  L 


70 


SET  UP  TO  SHIFT  DOWN  ELEMENT  TRAY  TO  ITS  PROPER  LEVEL 
IF  (J  . L£.  1R)  THEN 
IF  (J  .LT.  !R>  THEN 

COMPARE  THE  RAY  TERMINATION  TIMES. 

READ  (INFILE,  120,  REC*J  )  <TRAY2(K),  K*1 ,ARRL) 

READ  (INFILE,  120,  REC*(J+1>  >  (TRAY3(K) ,  K-1.ARRL) 
IF  (TRAY2(SRTFLD)  .LT.  TRAY3(SRTFLD))  J  2  J  ♦  1 
END  IF 

COMPARE  THE  RAY  TERMINATION  TIMES. 

READ  (INFILE,  120,  REC-J  )  (TRAY2(IO,  K*1,ARRL) 

IF  (TRAY(SRTFLD)  .LT.  TRAY2(SRTFLD>)  THEN 

WRITE  (INFILE,  120,  REC=I  )  (TRAY20O,  K=1  ,ARRL) 

I  *  J 
J  2  J  ♦  J 
ELSE 

J  2  IR  ♦  1 
END  IF 

LOOP  WHILE  J  LESS  THAN  OR  EQUAL  TO  IR. 

GO  TO  70 
ENOIF 

PUT  TRAY  INTO  ITS  SLOT. 

WRITEONFILE,  120,  REC*I  )  (TRAY(K) ,  K*1 , ARRL) 

LOOP  UNTIL  ARRAY  IS  SORTED. 

GO  TO  30 

100  CONTINUE 
RETURN 


120  FORMAT  (F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 
END 

*•  END  OF  SUBROUTINE  SORTRAY. 


************************************************************************ 


SUBRCCIT I NE  CONTUR  •«**••******•**••***•»*** 

r*****tt**«*******««******«***********«*«************«««******-*««***«*«** 


MOOULE  NAME 

:  CONTUR 

MOOULE  TYPE 

J  SUBROUTINE 

PROGRAMMER 

:  THOMAS  REILLY 

DATE 

:  DECEMBER  5,  1986 

REV I  SONS 

DESCRIPTION 

THIS  SUBROUTINE  IS  USED  TO  INVOKE  'GET I NX' ,  WHICH  RETU 

THE  STARTING  RECORD,  AND  NUMBER  OF  RECORDS  FROM  THE  INDEX  F 
FOR  FOR  A  VALID  FLIGHT  SEGMENT.  THIS  INFORMATION  IS  THEN  U 
TRANSFER  THE  DATA  FROM  THE  FILE  CLIBRY  TO  A  TEMPORARY  DATA 
THE  SUBROUTINE  SORTRAY  IS  THEN  CALLED  TO  SORT  THE  TEMPORARY 
ON  RAY  TERMINATION  TIME.  NEXT  THE  SUBROUTINE  GRIDPOU  IS  CA 
WHICH  CALCULATES  THE  GRID  POWERS  FOR  EACH  RAY. 


MOOULE  I/O  :  CONTUR  (MASTER,  SCRCNT,  SCRCH,  CONTFL,  SCRPAD,  SCRALL) 


INPUTS  : 

CONTFL  •  LOGICAL  :  TRUE  IF  CONTOURS  ARE  TO  BE  PLOTTED. 

SCRPAD  •  LOGICAL  :  TRUE  IF  SCRCHPADS  ARE  TO  BE  PLOTTED. 

SCRALL  -  LOGICAL  :  TRUE  IF  ALL  SCRCHPADS  ARE  TO  BE  PLOTTED. 


OUTPUTS  : 
MASTER 

LIMAXO 
LI MAYO 
LI  MAXI 
L I MAY 1 


INCLUDING  COMMON  BLOCKS. 

•  REAL (102, 102)  :  MASTER  ARRAY  CONTAINING  POWER  OF  INTI 

FLIGHT  TRACK. 

-  INTEGER  :  LOWER  LIMIT  OF  THE  X  INDICE  FOR  THE  GRID 

•  INTEGER  :  LOWER  LIMIT  OF  THE  Y  INDICE  FOR  THE  GRID 

•  INTEGER  :  UPPER  LIMIT  OF  THE  X  INDICE  FOR  THE  GRID 

-  INTEGER  :  UPPER  LIMIT  OF  THE  Y  INDICE  FOR  THE  GRID 


THE  FOLLOWING  VARIABLE  ARE  INPUTED  AND  OUTPUTED  ONLY  TO  ALLOW 
THE  MEMORY  THEY  OCCUPY  TO  BE  EOUI VALANCED . 

SCRCH  -  REAL ( 102, 1025  :  SCRATCH  ARRAY  CONTAINING  THE  POWERS  A 

EACH  GRID  POINT. 

SCRCNT  •  INT(102,10?'  :  COUNTER  OF  NUMBER  OF  RAYS  HITING  EACH 

GRID  POINT. 


FILE/tO  DICTIONARY  : 


CINDEX  •  INDEX  FILE  FOR  THE  RAY  DATA  FILE  CLIBRY. 

CLI8RY  -  DATA  FILE  FOR  THE  RAY  INFORMATION. 

TEMPFL  •  TEMPORARY  FILE  USED  TO  SORT  THE  RAYS  AND  CALCULATE  TH 
GRID  POWERS. 


VARIA8LE  DICTIONARY  : 


EOFFLG 

-  LOGICAL 

TRUE  IF  EOF  OF  THE  INDEX  FILE. 

EOFSEG 

•  LOGICAL 

TRUE  IF  ENO  OF  FLIGH  TRACK. 

GRNOZ 

•  REAL 

Z  COORDINATE  OF  THE  RAY  TERMINATION  AT  TH 

NREC 

•  INTEGER 

NUMBER  OF  RAY  RECORDS  FOR  THIS  FLIGHT  SEG 

OPR 

■  LOGICAL 

TRUE  IF  THERE  ARE  CAUSTICS  IN  THE  FLIGHT 

RAYS 

■  REAL! 11 ) 

ARRAY  USED  TO  TRANSFER  THE  RAY  DATA  TO  TH 

FILE. 

RSTIME 

•  REAL 

CONTAINS  THE  PREVIOUS  RAYS  START  TIME. 

SREC 

-  INTEGER 

STARTING  RECORD  OF  THE  RAY  RECORDS  FOR  FL 

TEMP 

•  REAL 

DUMMY  VARIABLE  USED  FOR  AN  UNNEEDED  RETUR 

PARAMETER. 

TEMPCT 

•  INTEGER 

: 

COUNTER  OF  THE  NUMBER  OF  RAYS  IN  THE  TEMP 

CALLED  MOOULES  : 


GETINX  (SREC,  NREC,  SOPR,  EOFFLG,  TEMP,  NOPR,  RAYINX)  ; 

SELECTS  VALID  FLIGHT,  RETURNS  SREC,  NREC,  EOFFLG. 

SRTRAY  (TEMPCT,  INFILE,  SRTFLD)  ; 

SORTS  RAYS  ON  THERE  GROUND  TERMINATION  TIME. 

INFILE  -  INTEGER  :  NUMBER  OF  FILE  TO  BE  SORTED. 
SRTFLD  -  INTEGER  :  FIELD  THE  FILE  IS  TO  BE  SORTED  ON. 

GRIDPW  (MASTER,  SCRCNT,  SCRCH)  ; 

CALCULATES  THE  GRID  POWERS  OF  THE  RAYS. 

CALLING  MODULE  : 


SUBROUTINE  CONTURC  MASTER,  SCRCNT,  SCRCH,  CONTFL,  SCRPAD,  SCRALL, 
1  TEMPAR,  TITLE,  LAT,  LONG) 


DECLARATION  OF  SUBROUTINE  INPUT/OUTPUT  VARIABLES. 
COMMON  /GRID/  GRDXQ,  XGS,  GRDXMX,  GRDYO,  YGS,  GRDYMX, 

1  LIMAXO,  LIMAYO,  LIMBXO,  LIMBYO, 

2  L I MAXI ,  LIMAY1,  LIMBX1,  LIMBY1 


INTEGER  L0W8N0,  UPBNO 

PARAMETER  (LOUBNO  *  -51,  UPBNO  ■  50) 

INTEGER  LIMAXO,  LIMAYO,  LIMAX1,  LIMAY1 

REAL  SCRCNT ( LOUBND : UPBNO , LOUBNO : UPBNO ) 

REAL  MASTER (LOUBND: UPBNO , L0W8N0 : UPBNO) ,  SCROULOUBND: 

UPBNO,  LOUBNO: UPBNO) 

LOGICAL  CONTFL,  SCRPAD,  SCRALL 

DIMENSION  TEMP AR(1 1,1 000) 

DECLARATION  OF  SUBROUTINE  OEPANOANT  VARIABLES/ 

INTEGER  MREC,  SREC,  TEMPCT,  NOPR,  SOPR,  J,  ARRL,  RTYPE 

INTEGER  LOOP,  TDAT ,  ELOOP 

PARAMETER  (ARRL  *  11) 

REAL  RAYS(ARRL),  RAYS2(ARRL),  RAYSJ(ARRL) ,  RAYSA(ARRL) 

LOGICAL  EOFFLG,  EOFSEG,  OPR,  EFILE 

CHARACTERS  10  BUF 
CHARACTER* 10  TOATE,  TT1ME 
CHARACTER*70  TITLE 
CHARACTER'S  ACTA I L 
CHARACTER'10  MS1TE,  LAT,  LONG 


ASSIGN  10  TO  LOOP 
ASSIGN  20  TO  TDAT 
ASSIGN  30  TO  ELOOP 

LOOP  UNTIL  END  OF  THE  INOEX  FILE. 
EFILE  «  -TRUE. 

EOFSEG  =  .FALSE. 

LIMAXO  »  102 
LIMAYO  =■  102 
LIMAX1  *  1 
LIMAY1  =>  1 
00  13,  I  ’  -51,  50 
00  12,  J  *  -51,50 
MASTER( J , I )  *  0.0 
SCRCH(J,I)  *  0.0 
SCRCNT(J,I)  *  0 
CONTINUE 
CONTINUE 


CONTINUE 

GET  STARTING  RECORD  ANO  NUMBER  OF  RECORDS  FROM  INDEX  FILE. 
CALL  GETINX(SREC,  NREC,  SOPR,  EOFFLG,  II,  NOPR,  OPR) 

SOPR1  *  SOPR 
NOPR1  =  NOPR 

IF  (NREC. LE.O. ANO. .NOT, EOF'LG)  GOTO  LOOP 
EREC  *  (SREC  ♦  NREC)  •  1 

CHECK  IF  ENO  OF  INOEX  FILE. 

IF  ((EOFFLG)  .ANO.  (EFILE))  RETURN 


EFILE  *  .FALSE. 

IF  (EOFFLG)  SO  TO  ElOOP 

ENTER  DATA  INTO  SCRATCH  PAO  FILE  TO  3E  PLOTTED  LATER. 

IF  ((OPR)  .AND.  (SCRPAD))  THEN 
READ(S1 , FMT*‘ (A) 1 , RECxI 1 )  SUF 
R£AD(SUF(61 :63) , FNT  =  ‘ (A8) 1 )  ACTAIL 
CALL  SCRHFL(SREC,  NREC,  SOPR,  NOPR,  ACTAIL,  SCRALL, 
TEMPAR) 

END  IF 

IF  (.NOT.(CONTFL))  THEN 
SOTO  10 
END  IF 

READ  THE  Z  GROUND  COORDINATE. 

R£AO(52,  15,REC*SREC)  GRN02 
FORMAT  (60X,  F10.2) 

GRNOZ  *  GRNDZ  /  0.3048 
READ (SI , FMTx‘ (A) ' , REC=1 1 )  BUF 
READ (8UF (27:36) , FMT*' (A10) 1 )  MSITE 
CALL  RNGLL (MSITE , LAT , LONG) 

SREC  *  SREC  ♦  1 
NREC  *  NREC  •  1 

TRANSFER  RAY  OATA  FROM  CLIBRY  TO  TEMPFL 

TEMPCT  *  1 

RS7IME  *  0.0 

CURT1ME  x  0.0 

NCNT  =  1 

START  LOOP  TO  TRANSFER  RAY  OATA. 

CONTINUE 

READ ( 52 , 25 , REC=SREC )  RTYPE, ( TEMPAR ( I , TEMPCT ) , I =1 , ARRL ) 

IF  (OJRTIM  .EC.  0.0)  CURTIN  x  TEMPAR(1 , TEMPCT) 

IF  ((CURTIM  .NE.  TEMPAR( 1 .TEMPCT) )  .OR.  (RTYPE  .EQ.  0))  THEN 
TEMPCT  *  TEMPCT  -1 
IF  (TEMPCT  .GT.  1)  THEN 
CALL  SORTRY( TEMPCT, TEMPAR, 8) 

ENOIF 

UR  I TE (33,35 , REC=NCNT )  (T£MPAR(K, 1 ),K=1 ,ARRL) 

NCNT  *  NCNT  ♦  1 
DO  200  I  *  2,  TEMPCT 

DPHI  X  I  NT (ABS(TEMPAR(8, 1 )  -  TEMPAR(8, 1  - 1 )))  -  1 
CPU I  x  TEMPAR(8,I-1> 

IF  ((DPHI  .GT.  2)  .AND.  (ABS(TEMPAR(8, I ) )  .LT.  180.) 
.AND.  (ABS(TEMPAR(8,I-13)  .LT.  180.))  THEN 
DO  250  L  x  1,  DPHI 
CPHI  x  CPH I  ♦  1.0 

FACTOR  x  (CPH I  - TEMPAR (8, 1*1) )/(TEMPAR(8, 1 )  - 
TEMPAR(8, I -1 )) 

RAYS2( 1 )  =  TEMPAR ( 1 , I ) 

RAYS2(2)  =  TEMPAR( 2 , I ) 

RAYS2(3)  =  TEMPAR(3, 1 ) 


RAYS2(4)  «  TEMPAR (4, I ) 

RAYS2(L)  «  TEMPAR(5, I'D  ♦  (TEMPAR(5,I)  •  TEMPAR 
<5,1* 1))*FACT0R 

RAYS2C6)  «  TEMPAR(6, I -1 )  *  (TEMPAR(6,I)  -  TEMPAR 
(6, I-1))*FACT0R 

RAYS2(7)  =  TEMPAR( 7, ID  ♦  (TEMPAR(7,I)  -  TEMPAR 
(7, 1 -1 ))*FACTOR 
RAYS2C8)  *  CPHI 

RAYS2C9)  ■  TEMPAR (9, I ■ 1 >  ♦  (TEMPAR(9,I)  •  TEMPAR 
(9, I -1 ))*FACTOR 

IF  ((TEMPAROO, 1*1)  .ME.  -1.0)  .AND.  (TEMPAR(10, 

I)  .ME.  -1.0))  THEM 

RAYS2(10)  *  TEMPAR(1Q, I • 1 )  *  (TEMPAR(10,I)  - 
TEMPAROO,  I -1))« FACTOR 

ELSE 

RAYS2O0)  *  -1.0 
END  IF 

RAYS2(11)  *  TEMPAR(1 1,1-1)+  (TEMPAR(1 1 , I )  -  TEMPAR 
(11,1- 1 ))*FACTOR 

WR!TE(33,35,REC=NCNT)  (RAYS2(K> ,K*1 ,ARRL> 

MCNT  *  NCNT  +  1 
CONTINUE 
ENOIF 

URITE(33,35,REC*NCNT)  (TEMPARCK, I ) ,K=1 ,ARRL ) 

NCNT  *  MCNT  ♦  1 
CONTINUE 
TEMPCT  *  0 
CURTIM  *  0.0 
IF  (RTYPE  .EQ.  0)  THEN 

READ(52,25,REC=SREC)  RTYPE, (RAYS20O ,K*1 ,ARRL) 

IF  ((RTYPE  .EQ.  0)  .AND.  (SPEC  .IE.  EREC))  THEN 
WRITE(33,35,REC=NCNT)  (RAYS2CK) , K=1 , ARRL > 

NCNT  *  NCNT  ♦  1 
SREC  *  SREC  ♦  1 
IF  (SREC  .IE.  EREC)  GOTO  215 
ENOIF 

IF  (SREC  .GT.  EREC)  GOTO  45 
SREC  *  SREC  •  1 
EHOIF 
ENOIF 

FORMAT  (12,  F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 

FORMAT  (F8.2,  3F8.0,  F8.2,  2F8.0,  F8.3,  3F10.4) 

IF  (RSTIME  .EQ.  0.0)  THEN 
RSTIME  *  RAYS(1) 

ENO  IF 

IF  ((RAYS(1)  -  RSTIME)  .GT.  5.5)  THEN 
RSTIME  «  RAYS(1 ) 

ELSE 

IF  (SREC  .LT.  EREC)  THEN 
SREC  =  SREC  +  1 
TEMPCT  *  TEMPCT  ♦  1 
RSTIME  x  RAYS(1) 

GO  TO  TOAT 


IF  (TEMPCT  .GT.  1)  THEN 
TEMPCT  ■  TEMPCT  ♦  1 
CURTIN  *  0.0 
GOTO  31 
END  IF 
END  IF 
ENO  IF 

*•  END  OF  TRANSFER  LOOP. 

45  CONTINUE 

*-  SORT  THE  FLIGHT  SEGMENT  ON  TERMINATION  TIME. 

CALL  SRTRAY ((NCNT-1),  33,  5) 

•-  CALCULATE  THE  GRID  POWERS. 

IF  (SREC  .GE.  EREC)  THEN 
EOFSEG  *  .TRUE. 

ENO  IF 

CALL  GRIDPW  (GRNDZ,  NCNT-1,  MASTER,  SCRCNT,  SCRCH) 
OPVAL  *  -99999.0 

DO  S00  IJ  a  SOPR1,  ( (NOPR1+SOPR1 ) - 1 ) 

READ (52, 1001 , REC=I J }  T1 , T2, T3, T4, T5,XC, TC, OPV, T6, T7 
1001  FORMAT(F8.2,3F8.Q, F8.2,2F8.0,3F10.4) 

IF  (OPVAL  .LT.  OPV)  THEN 
OPVAL  »  OPV 
XCOORD  *  XC 

tcoord  *  rc 

END  IF 

500  CONTINUE 

XCOORD  a  INT (XCOORD/O.3048) 

TCOORD  =  INT(YCOORD/O.3048) 

UR  t  TE( 5 , FMT= ' (2F 1 0 . 0 ) ' )  XCOORD , TCOORD 

IF  (.NOT.  EOFSEG)  THEN 
GO  TO  TOAT 
ELSE 

GO  TO  LOOP 
END  IF 


•ELOOP  ENO  OF  INDEX  FILE  OUTPUT  MASTER  ARRAY. 

30  CONTINUE 

•-  PUT  MASTER  ARRAY  INTO  D8. 

OO  28  I  a  -  5 1 ,49 

DO  26  J  a  -51,49 

IF  (MASTER( J+1 , 1+1 )  .GT.  0.0)  THEN 

MASTER(J,t)  =  20  •  LOG10(MASTER(J+1 , 1+1 ) )  +  68 
END  I  F 

26  CONTINUE 

28  CONTINUE 

C 

C  WRITE  GRID  ON  LINE  PRINTER 

C 


c*&*&* 


TO  OUTPUT  THE  LINE  PRINTER  PLOTS  REMOVE  THE  FOLLOWING  GOTO. 


GOTO  830 
WRITE  (15,6920) 
WRITE  (15,6921) 
WRITE  (15,6920) 
WRITE  (15,6921) 
WRITE  (15,6920) 
WRITE  (15,6921) 
WRITE  (15,6920) 
WRITE  (15,6921) 
830  CONTINUE 


(I,  1*1,25) 

(50- J,  ( MASTERd, 50- J),  I*-50,-26),  J--50.49) 
(I,  1*26,50) 

(50- J,  (MASTERd  ,50-J),  I  =  - 25 , - 1 ) ,  J*-50,49) 
(I,  1*51,75) 

(50-J,  (MASTERd ,50-J),  1=0,24),  J*-50,49) 

(I,  1*76,100) 

(50-J,  (MASTERd  ,50-J),  1*25,49),  J*-50,49) 


C 

IF  (CONTFL)  THEN 

CALL  CPCONT(TITLE , TOATE , TTIME , LAT , LONG, MASTER) 
CALL  CPMX0P(T1TL£, TOATE, TTIME, LAT, LONG) 

ENOIF 

6920  FORMAT  (  •  1  ■ ,  5X.25I5) 

6921  FORMAT  ('O',  14,  IX,  25F5.1) 

RETURN 

ENO 

*-  ENO  OF  SUBROUTINE  CONTOUR. 


SUBROUTINE  PLOTDR 


MOOULE  NAME  :  PLOTDR 
MODULE  TYPE  :  SUBROUTINE 

PROGRAMMER  :  THOMAS  REILLY 
DATE  :  APRIL  22,  1987 

REVISIONS  : 

DESCRIPTION  : 

THIS  SUBROUTINE  WAS  DESIGNED  TO  DRIVE  THE  SCRCHPAD 
PLOTTING  SUBROUTINES  AND  THE  CONTOURING  SUBROUTINES. 

MOOULE  I/O  :  PLOTDR (MASTER,  SCRCH,  SCRCNT) 


INPUTS  : 

CONTFL  •  LOGICAL  :  TRUE  IF  CONTOURS  ARE  TO  BE  PLOTTED. 

MASTER  •  HEAL C 1 02 ,1025  :  MASTER  ARRAY  FOR  THE  CONTOUR  GRID. 

SCRCH  •  REAL <102, 102)  :  SCRCH  ARRAY  FOR  THE  CONTOURING. 

SCRCNT  •  INT  (102,102)  :  SCRCH  COUNTER  ARRAY  FOR  THE  CONTOURING. 

SCRPAD  -LOGICAL  :  TRUE  IF  THE  SCRCHPAD  PLOTS  ARE  TO  BE  PL 

SCRPSF  •  LOGICAL  :  TRUE  IF  THE  SCRCHPAD  PLOTS  ARE  TO  BE  IN 

SCRALL  -LOGICAL  :  TRUE  IF  ALL  THE  SCRCHPAD  PLOTS  ARE  TO  B 

OUTPUTS  :  NONE. 

FILE  DICTIONARY  : 


CLIBRY  •  CONTAINS  THE  RAY  LIBRAY. 

CINDEX  -  INDEX  TO  THE  DIRECT  ACCESS  FILE  CLIBRY. 

HOLDFL  -  TEMPORARY  FILE  USED  IN  THE  SCRCHPAD  PLOTTING. 

TEMPFL  -  TEMPORARY  FILE  USED  IN  THE  CONTOUR  PLOTING 

SCRCHFL  -  FILE  USED  IN  THE  SCRCHPAD  PLOTTING. 


SUBROUTINE  PLOTDR(TITLE,GPCPFL,  GPCPMH,  GPCPBM) 

COMMON  /STATS/  STATFL,  BOOMFL,  MACHFL,  CONTFL,  BOOMVA, 

1  MACHVA,  CONTVA,  CONTYP,  WIDTH,  FFT ,  SIGNAT, 

2  RAYTRC,  SCRPFL ,  SCRPSF,  SCRALL 

INTEGER  CONTYP(5) 

REAL  800MVA,  MACHVA,  WIDTH,  CDNTVA(5,20) 

LOGICAL  STATFL,  BOOMFL,  MACHFL,  CONTFL,  FFT,  SIGNAT, 

1  RAYTRC,  SCRPFL,  SCRPSF,  SCRALL,  GPCPFL , GPCPMH , 

1  GPCPBM 

CHARACTER*70  title 
CHARACTER'10  LAT, LONG , TOATE , TT IME 


REAL  SCRCNT( -51:50, -51:50) 

REAL  MASTERC -51:50, -51:50),  SCRCH( -51 :50, -51 :50) 

DIMENSION  TEMPAROI ,1000) 


0PEN(33, FI LE*' TEMPFL 1 , ACCESS® 'DIRECT ' , FORM" 'FORMATTED', 

1  RECL*100) 

OPEN(32, FI LE* 1 SCRCHFL 1 .ACCESS* ' SEQUENT  I AL 1 , FORM* 1  FORMATTED 1 ) 
OPEN ( 5 1 , F 1 LE  * ' C I NDEX • , STATUS* 'UNKNOWN 1 , ACCESS* 'DIRECT', 

1  FORM* • FORMATTED 1 , RECL* 1 1 0 , BLANK* ' NULL ■ ) 

OPEN(52 , F I LE* ' CL IBRY  * , STATUS* ' UNKNOWN ■ .ACCESS* 'D IRECT 1 , 

1  ''ORM* '  FORMATTED 1 ,  RECL*  110,  BUNK*  *  NULL '  ) 

0PENC34, FI LE* • HOLDFL ' .ACCESS* • SEQUENTIAL ' , FORM* ' FORMATTED ' ) 
OPEN  <  35 , F I LE* ' TMPFL2 ' , ACCESS* ' 0 IRECT ' , FORM* ' FORMATTED ' , 

1  RECL* 100) 

OPEN( 1 1 , FI LE*' TAPE1 1 ' .ACCESS* ' SEQUENTIAL ' , FORM* ' FORMATTED ' ) 
OPEN(5,FILE*'FIL5') 


CALL  CONTUR  TO  CREATE  CONTOUR  PLOTS  AND  SET  UP  SCRPAD  FILE. 
IF  (GPCPFL)  CALL  CPINIT(TITLE) 

CALL  CONTUR(MASTER,  SCRCNT,  SCRCH,  CONTFL,  SCRPFL,  SCRALL, 

1  TEMPAR,  TITLE, LAT.LONG) 

IF  (GPCPFL)  THEN 

IF  (GPCPMH)  CALL  CPSSTR(TITl£,  TOATE,  TTIME,  LAT.LONG) 

IF  ( GPCPBM )  CALL  CPBMTR(TITL£,  TDATE,  TTIME,  LAT.LONG) 

CALL  CPTERM 
END  IF 

CHECK  IF  SCRCH  PAD  PLOTS  ARE  TO  BE  PLOTTED. 

IF  (.NOT.  (SCRPFL))  RETURN 
CALL  SCRPAO(SCRPSF, TEMPAR) 


RETURN 


SUBROUTINE  RNGLL  (SITLC,  LAT,  LONG) 


01  MENS ION  S1TEC20),  SITLAT(20),  S!TLON(20) 

CHARACTER*^  SITE,  S1TLAT,  SITLON,  LAT,  LONG 
CHARACTER^*)  SITLC 


OO  20  1*1,20 

LAT  *  SITLAT(I) 

LONG  *  SITLON(I) 

IF  (SI TEC  1)  .EQ.  '  ')  RETURN 
IF  (SITLC  .EQ.  SITE(I))  RETURN 
20  CONTINUE 

LAT  =  '  1 
LONG  *  '  ' 

RETURN 


DATA  SITE/' OCEANA',  'TYNDALL',  'LUKE',  'HOLLOMAN', 
1  , ' YUMA ' , 14* '  '  / 

DATA  SITLAT / '  36  00.0  M ' , '  29  32.0  N','  32  23.48N', 
1  ,'36  50.29N ' , '  32  29.24N',14*'  UNKNOWN 
DATA  SITLON/'  75  10.0  U','  84  37.0  U','113  15.0  U', 
1  ,'115  25.36U' , '113  52.56U',14*'  unknown 
END 


'NELLIS' 

'  33  48.0  N 
'  / 

'106  25.0  W 
'  / 


SUBROUTINE  CPTERM 
C 

C  ROUTINE  TO  TERMINATE  GPCP  FILE 

C 

WRITE  (11,1101) 

ENOFILE  11 
REWINO  11 
RETURN 

1101  FORMAT  ('STOP') 

ENO 


C 


c 

r 

c 

c 

c 

c 


c 


.****»******************•***♦*****************•******************** 

SUBROUTINE  CPINIT  (TITLE) 

ROUTINE  TO  INITIALIZE  OUTPUT  TO  GPCP 

CHARACTER* (*)  TITLE 

REWIND  11 

RETURN 

ENO 


c 

Q*«****«*«*****«*««*«*«**« *«**************«**•***•**««**•*•****«***«***• 

SUBROUTINE  CPCONT  (TITLE,  TDATE',  TT1ME,  LAT,  LONG,  GRID*) 

C 

C  ROUTINE  TO  OUTPUT  GPCP  CARDS  TO  PLOT  CONTOURS 

C 

c 

COMMON  /GRID/  GRDXO,  XGS,  GRDXMX ,  GRDYO,  YGS,  GRDYMX , 

1  LIMAXO,  L1MAY0,  LIMBXO,  LIM8Y0, 

2  L1MAX1 ,  L1MAY1 ,  L1MBX1 ,  LIMBY1 
C 

COMMON  /STATS/  STATFG,  BOOMFG,  NACHFG,  CONTFG,  BOOMVL, 

♦  MACHVL,  CONTVL(5,20),  CONTYP<5),  WIDTH,  FFT, 

♦  SI GNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 
C 

DIMENSION  IAN(S),  GRIDA<102, 102) 

C 

CHARACTER* (*)  TITLE,  TDATE,  TTIME,  LAT,  LONG 
CHARACTER*70  MAPANO,  XANO,  YANO,  MAP<3) 

CHARACTER  MAPI *30,  MAP2*30,  MAP3*10 
C 

INTEGER  CONTYP 

LOGICAL  CONFG,  FFT,  SIGNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 
C 

DATA  IAN  /  -100000,  -50000,  0,  50000,  100000  / 

DATA  NAP(1 )  /'CONTOURS  OF  AVERAGE  C- WEIGHTED  SOUND  EXPOSURE  LEVEL 
1  (CSEL) ,  IN  08'/ 

DATA  MAP(2)  /'CONTOURS  OF  C- WEIGHTED  DAY/NIGHT  AVERAGE  LEVEL  (DNL 
1),  IN  DB'/ 

DATA  MAP(3)  /'CONTOURS  OF  AVERAGE  PEAK  OVERPRESSURE  IN  POUNDS  PER 
1  SQUARE  FOOT'/ 

DATA  XANO  /'RANGE  X-COORDINATE  IN  FEET'/ 

DATA  YANO  /'RANGE  Y-CO  ORDINATE  IN  FEET'/ 

C 

CONFG  *  .FALSE. 

C 

DO  100  KK*1 ,5 

IF  (CONTYP(KK)  .EO.  0)  RETURN 
NCTYPE  *  CONTYP (KK) 

IF  (NCTYPE  .LT.  1  .OR.  NCTYPE  .GT.  3)  STOP80 
MAPANO  *  MAP (NCTYPE) 

C 

IF  (CONTVL(KK.I)  .LE.  0.  .OR.  CONTVL(KK,2)  .LE.  0.)  GOTO  100 
C 

WRITE  (11,1101)  TITLE 

PWIDTH  *  AHAXl (8.0,  AMINKWIDTH,  48.)) 

WRITE  (11,1102)  PWIDTH 
WRITE  (11,1103)  16 

C 

SCALE  *  CONTVL(KK.I)  /  12.0 
. ISCALE  *  ! FIX( SCALE  ♦  0.5) 

1GS  *  I F I X ( XGS  +  0.5) 

XMIN  -  GRDXO  ♦  XGS/2.0 


XMAX  *  GROXMX  -  XGS/2.0 
YMIN  ■  GROYO  ♦  YGS/2.0 
YMAX  ■  GRDYMX  •  YGS/2.0 

IF  THIS  IS  LON  CONTOUR,  EXTRACT  REFERENCE  NUMBER  OF  OPS 

IF  (NCTYPE  .EO.  2)  THEN 
FNOPS  ■»  CONTVL(KK,2) 

OPSAOJ  «  10.  *  ALOGIO(FNOPS) 

IPTR  «  3 
ELSE 

IPTR  ■  2 
END  IF 

WRITE  (11,1104)  ISCALE,  ISCALE,  0.,  1.50,  XMIN,  IGS,  XMAX, 

1  YMIN,  IGS,  YMAX 

IF  THIS  IS  MOT  THE  FIRST  CONTOUR  MAP  THEN  SIMPLY 
RESTORE  THE  GRID  ARRAY,  OTHERWISE  OUTPUT  THE  CONTROL 
POINTS  SO  ARRAY  CAN  BE  GENERATED 

IF  (CONFG)  THEN 
WRITE  (11,1111) 

ELSE 

WRITE  (11,1112) 

WRITE  (11,1105)  0.17,  0.17,  1,  2,  21,  21 

10  *  MAXQ( 1 ,  L1MAXO-2) 

11  *  MIN0(100,  LI MAX 1*2) 

JO  *  MAX0( 1 ,  LIMAYO-2) 

J1  »  MINOOOO,  LI  MAY  1*2) 

DO  40  I»I0,I1 

XP  *  GRDXO  ♦  XGS*FLOAT(I • 1 ) 

DO  40  J»J0,J1 

YP  *  GROYO  ♦  YGS*FLOAT ( J - 1 ) 

40  WRITE  (11,1106)  XP,  YP,  GRIDA(I.J),  2 

WRITE  (11,1107) 

CONFG  «  .TRUE. 

END  IF 

OUTPUT  CONTOUR  VLUES  TO  BE  PLOTTED 

0SETL8  *  0. 

DO  50  I*IPTR,20 

IF  (CONTVL(KK, I )  .LE.  0.)  GOTO  60 
IF  (NCTYPE  .EG.  1)  THEN 
CONLAB  =  CONTVL(XX, I ) 

CONLEV  =  CONLAB 
NOCHRS  *  4 
I FMT  «  0 

ELSEIF  (NCTYPE  .£0.  2)  THEN 
CONLAB  *  CONTVLCKK, I ) 


CON  LEV  ■  CONUS  •  OPSADJ  ♦  49.3651 
NOCHRS  ■  4 
IFMT  *  0 

ELSE IF  (NCTYPE  .EO.  3)  THEN 
CONLA8  «  CONTVL(KK.I) 

CONLEV  ■  20.  *  ALOGIO(CONLAB)  *  101.6 
NOCHRS  *  4 
IFMT  »  1 
END  IF 

WRITE  (11,1108)  CONLEV,  CONUS,  OSETLS,  0.125,  1,  NOCHRS,  IFMT 
OSETLS  *  OSETLS  ♦  1.50 
50  CONTINUE 
C 

60  CONTINUE 

WRITE  (11,1109) 

C 

C  CALCUUTE  HEIGHT  OF  'TITLE1  CHARACTERS  (MAX=0.2S  IN) 

C  AND  PLOT  TITLE 

C 

BRDRLH  *  (YMAX  ■  YMIN)  /  SCALE 

CHGHT  *  AMINK0.2S,  (BRORLN'2.5)  /  80.) 

WRITE  (11,1120)  0.500,  1.000,  0.0,  CHGHT,  TITLE(1:30), 

1  TITLE(31 :60) ,  TITL£(61:70> 

C 

C  CALCUUTE  HEIGHT  OF  'MAP  TYPE'  AND  'SCALE'  CHARACTERS 

C  (MAX*0.20  IN)  ANO  PLOT  2  LINES  OF  TEXT 

C 

CHGHT  *  AMINK0.20,  (BRDRLN-3.0)  /  80.) 

MAPI  *  MAPANO( 1:30) 

MAP2  *  MAPANO(31:60) 

MAP3  *  MAPAN0(61 :70) 

WRITE  (11,1120)  1.000,  0.625,  0.0,  CHGHT,  MAPI, 

1  MAP2,  MAP3 

WRITE  (11,1122)  1.000,  0.250,  0.0,  CHGHT,  ISCALE,  LAT,  LONG 

C 

C  DRAW  BOX  AROUND  TITLE  BLOCK 

C 

WRITE  (11,1121)  0.00,  1.50,  0.00,  0.00, 

1  0.00,  0.00,  SRDRLN,  0.00, 

2  8R0RLN,  0.00,  BRORLN,  1.50, 

3  BRDRLN-1.5,  1.50,  BRORLN- 1 .50,  0.0 
C 

C  PUT  TIC  MARKS  ON  MAP  EDGE 

C 

YTICO  •  1.5 

YTIC1  *  YTICO  +  0.15 

DO  82  1*1,9 

XT  I C  *  FLOAT ( I )  *  BRORLM  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
82  CONTINUE 
C 

YTICO  *  BRORLN  ♦  1.5 
YTIC1  *  YTICO  -  0.15 
DO  84  1*1,9 


XTIC  ■  FLOAT ( I )  •  BRDRIN  /  10. 

WRITE  <11,1121)  XTIC,  TTICO,  XTIC,  YT1C1 
34  CONTINUE 
C 

XT I CO  »  0.0 

XT  I  Cl  *  XT  ICO  +  0.15 

00  86  1*1,9 

YTIC  *  FLOAT  Cl)  *  8R0RLN  /  10.  ♦  1.5 
WRITE  (11,1121)  XTICO,  YTIC,  XTIC1 ,  YTIC 
86  CONTINUE 
C 

XTICO  *  SRORLN 

XT! Cl  ■  8R0RLN  •  0.15 

DO  88  1*1,9 

YTIC  *  FLOATY  I)  *  SRORLN  /  10.  +  1.5 
WRITE  (11,1121)  XTICO,  YTIC,  XT  I Cl,  YTIC 
38  CONTINUE 
C 

C  PUT  COORDINATE  ANNOTAION  ON  S10ES  OF  MAP 

C 

XP  *  BRDRLN/2.  •  2.6 
YP  «  SRORLN  ♦  1.5  ♦  0.35 
MAPI  ■  XANO(1:30) 

MAP2  *  XANO(31 : 60) 

WRITE  (11,1140)  XP,  YP,  0.,  0.1,  MAPI,  MAP2 
YP  *  BRORLN  ♦  1.6 
DO  92  1*1,5 

XP  »  <F10AT(IAN<I)>  -  XMIN)  *  BRORLN  /  CXMAX-XM1N)  ■  0 
92  WRITE  (11,1130)  XP,  YP,  0.,  0.1,  10,  IAN(I) 

C 

XP  =  -0.35 

YP  *  BRDRLN/2.  ♦  1.5  •  2.6 
MAPI  »  YANO<1 :30) 

MAP2  *  YANO(31:60) 

WRITE  (11,1140)  XP,  YP,  90.,  0.1,  MAPI,  MAP2 
XP  *  -0.1 
DO  94  1*1,5 

YP  *  <FLOAT( IAN( I ))  -  YMIN)  *  BRORLN  /  (YMAX-YMIN)  +  0 
94  WRITE  (11,1130)  XP,  YP,  90.,  0.1,  10,  IAN(I) 

C 

C  DRAW  A  AT  THE  RANGE  CENTER  (COORDINATES  0,0) 

C 

XORG  *  (0.0  -  XMIN)  /  SCALE  ♦  0.0 
YORG  *  (0.0  -  YMIN)  /  SCALE  ♦  1.5 
WRITE  (11,1121)  XORG,  YORG -0.25 ,  XORG,  YORG+0.25, 

1  XORG -0.25,  YORG,  X0RG+0.25,  YORG 

C 

C  ENO  OF  MAP 

C 

WRITE  (11,1110) 

100  CONTINUE 
C 

RETURN 

C 


c 


1101  FORMAT  C'JOSX  A70) 

1102  FORMAT  ('PACE  •,  F4.1) 

1103  FORMAT  ('REF  ■,  12) 

1104  FORMAT  C'SIZX  215,  2F5.1,  2(F10.0,  15,  F10.0)) 

1105  FORMAT  ( 'CNTL  ',  2F5.2,  215,  45X,  215) 

1106  FORMAT  ( 'CNTL  ',  2F10.0,  F10.3,  35X,  12) 

1107  FORMAT  ( ' BEND 1 ) 

1108  FORMAT  ('LEV  ',  2F5.1,  2F5.2,  20X,  315) 

1109  FORMAT  ( 1 BRDR ' ) 

1110  FORMAT  ('ENO') 

1111  FORMAT  C'RESA',  26X,  1  2') 

1112  FORMAT  ('SAVA') 

1120  FORMAT  CSYMB  O',  4F5.3,  •  30',  15X,  A30  / 

1  'ETCS  ',  25X,  '  30',  15X,  A30  / 

2  'ETCS  ',  25X,  '  10',  15X,  A10  ) 

1121  FORMAT  CLINE  O',  4F5.2,  19X,  '1'  ) 

1122  FORMAT  ('SYM8  O',  4F5.3,  '  30',  15X,  'SCALE:  1  INCH  18, 

1  '  FEET  '  / 

2  'ETCS  ',  25X,  •  24',  15X,  '  ORIGIN:  LAT  ',  A10/ 

3  'ETCS  ',  25X,  '  17',  15X,  1  LONG  ',  A10  ) 

1130  FORMAT  CSYMB  O',  4F5.2,  15,  15X,  110) 

1140  FORMAT  ('SYM8  O',  4F5.2,  '  -30',  15X,  A30  / 

1  'ETCS  ',  25X,  '  30'.  15X,  A30) 

END 


£-*»*«*«**»«»***»»»*******»***»»«*»**»»*****»»**««*«****»»**««»**l 

c 

SUBROUTINE  CPSSTR  (TITLE,  TDATE,  TTIME,  LAT,  LONG) 

C 

C  ROUTINE  TO  OUTPUT  GPCP  CAROS  FOR  PLOTTING  SUPERSONIC 

C  FLIGHT  TRACKS 

C 


C 


C 


C 

c 


COMMON  /GRID/  GROXO,  XGS,  GRDXMX,  GROYO,  YGS,  GROYMX, 

1  LIMAXO,  LIMAYO,  LIMBXO,  LIMBYO, 

2  L1HAX1,  LIMAY1 ,  LIMBXl ,  LIM8Y1 

COMMON  /STATS/  STATFG,  BOOMFG,  MACHFG,  CONTFG,  BOOMVL, 

♦  MACHVL ,  CONTVLC5 ,20) ,  CONTYP(S),  WIDTH,  FFT, 

♦  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 


INTEGER  CONTYP 

LOGICAL  FFT,  SIGNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 
DIMENSION  IAN(S) 


CHARACTER*!*)  TITLE,  TDATE,  TTIME,  LAT,  LONG 
CHARACTER  MAP 1 *30 , MAP2*30 , MAP3*1 0 
CHARACTER*70  MAPANO,  xano,  yano 


REAL  MACHVL 

OATA  IAN  /  -100000,  -50000,  0,  50000,  100000  / 

DATA  MAPANO  /'FLIGHT  TRACK  SEGMENTS  OF  SUPERSONIC  AIRCRAFT  ACTIVI 
1TY  (MACH  >1)'/ 

DATA  XANO  /'RANGE  X-COORDINATE  IN  FEET'/ 

DATA  YANO  /'RANGE  Y-COORDINATE  IN  FEET'/ 

C 
C 

FTOELM  *  999999. 

C 

WRITE  (11,1101)  TITLE 

PWIOTH  *  AMAXl (8.0,  AMINKWIDTH,  48.)) 

WRITE  (11,1102)  PWIOTH 
C 

SCALE  *  MACHVL  /  12.0 
ISCALE  *  IFtX(SCALE  ♦  0.5) 

IGS  *  I F I X (XGS  ♦  0.5) 

XMIN  «  GRDXO  *  XGS/2.0 
XMAX  *  GROXMX  -  XGS/2.0 
YMIN  *  GRDYO  ♦  YGS/2.0 
YMAX  *  GROYMX  -  YGS/2.0 

WRITE  (11,1104)  ISCALE,  ISCALE,  0.,  1.50,  XMIN,  IGS,  XMAX, 

1  YMIN,  IGS,  YMAX 

C 


WRITE  (11,1105) 

C 

C  REWINO  UNIT  3  WITH  FLIGHT  TRACK  X/Y  COORDINATES 

C 


REV I  NO  3 


C 

XI  *  FTOELM 

Y1  *  0. 

C 

C  KEEP  TRACK  OF  PREVIOUS  COORDINATES 

C 

10  XO  «  XI 
TO  *  Y1 
C 

C  READ  NEXT  COORDINATE  PAIR 

C 

15  REAO  (3,3001 ,END*100)  XI,  Y1 
C 

C  CONVERT  COORDINATES  TO  PLOTTER  INCHES  IF  THIS 

C  COORDINATE  PAIR  IS  VALID,  ANO  LIMIT  TO  BOARDER 

C  (GPCP  INPUT  CARD  FIELD  LENGTH  LIMITATION) 

C 

IF  (XI  .EQ.  FTOELM)  GOTO  10 
XI  *  AMAXKXMIN,  AMINKX1,  XMAX)) 

Y1  *  AMAXKYMIN,  AMINKY1,  YMAX)) 

XI  •  (XI  •  XMIN)  /  SCALE 

Y1  *  (Y1  •  YMIN)  /  SCALE  ♦  1.5 

C 

C  OUTPUT  A  LINE  SEGMENT  ONLY  IF  CURRENT  AND  PREVIOUS 

C  COORDINATES  ARE  VALID  ANO  AT  LEAST  ONE  IS  INSIDE  BOARDER 

C 

IF  (XO  .£0.  FTOELM)  GOTO  10 

IF  (ABS(XI-XO)  .LT.  0.015  .AND.  ABS(YI-YO)  .LT.  0.015)  GOTO  15 
WRITE  (11,1106)  XO,  YO,  XI,  Y1 
GOTO  10 
C 

C  CALCULATE  HEIGHT  OF  'TITLE'  CHARACTERS  (MAX*0.25  IN) 

C  ANO  PLOT  TITLE 

C 

100  CONTINUE 

BRDRLN  *  (YMAX  -  YMIN)  /  SCALE 

CHGHT  »  AMIN1(0.25,  (BRDRLN-2.5)  /  80.) 

WRITE  (11,1120)  0.500,  1.000,  0.0,  CHGHT,  TITLE(1:30), 

1  T ITLE (31 :60) ,  TITLE(61:70> 

C 

C  CALCULATE  HEIGHT  OF  ‘MAP  TYPE’  AND  'SCALE'  CHARACTERS 

C  (MAX *0.20  IN)  ANO  PLOT  2  LINES  OF  TEXT 

C 

CHGHT  «  AMINK0.20,  (BR0RLN-3.0)  /  80.) 

MAPI  *  MAPANO( 1:30) 

MAP2  *  MAPANO(31 :60) 

MAP3  *  MAPANO(61:70) 

WRITE  (11,1120)  1.000,  0.625,  0.0,  CHGHT,  MAPI, 

1  MAP2,  MAP 3 

WRITE  (11,1122)  1.000,  0.250,  0:0,  CHGHT,  ISCALE,  LAT,  LONG 

C 

C  DRAW  BOX  AROUND  TITLE  BLOCK 

C 


WRITE  (11,1121)  0.00,  1.50,  0.00,  0.00, 

1  0.00,  0.00,  BRORLM,  0.00, 

2  BRORLM,  0.00,  BRDRLN,  1.50, 

3  BRORLM- 1.5,  1.50,  BRORLM- 1.50,  0.0 

C 

C  PUT  TIC  HARKS  ON  HAP  EDGE 

C 

YTICO  *  1.5 

YTIC1  *  YTICO  ♦  0.15 

DO  82  1*1,9 

XTIC  *  FLOAT ( I )  •  BRORLM  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YT1C1 
82  CONTINUE 
C 

YTICO  *  BRORLM  ♦  1.5 
YT X Cl  *  YTICO  •  0.15 
DO  84  1*1,9 

XTIC  *  FLOAT(l)  *  BRORLM  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
84  CONTINUE 
C 

XT I  CO  *  0.0 

XT  I  Cl  *  XT  I  CO  ♦  0.15 

DO  86  1*1,9 

YTIC  *  FLOAT ( I )  *  BRORLM  /  10.  ♦  1.5 
WRITE  (11,1121)  XT I CO,  YTIC,  XTIC1,  YTIC 
86  CONTINUE 
C 

XT I  CO  *  BRORLM 
XTIC1  *  BRORLM  •  0.15 
DO  88  1*1,9 

YTIC  *  FLOAT ( I )  *  BRORLM  /  10.  ♦  1.5 
WRITE  (11,1121)  XT  I  CO ,  YTIC,  XTIC1,  YTIC 
88  CONTINUE 
C 

C  PUT  COORDINATE  ANNOTAION  ON  SIDES  OF  MAP 

C 

XP  »  BRDRLN/2.  -  2.6 
YP  *  BRORLM  +  1.5  ♦  0.35 
MAPI  *  XANO(1 :30) 

MAP2  *  XANO(31 :60) 

WRITE  (11,1140)  XP,  YP,  0.,  0.1,  MAPI,  MAP2 
YP  *  BRORLM  +1.6 
DO  92  1*1,5 

XP  *  (FLOAT(IANO))  -  XMIN)  *  BRORLM  /  (XMAX-XMIN)  • 
92  WRITE  (11,1130)  XP,  YP,  0.,  0.1,  10,  IAN(I) 

C 

XP  *  -0.35 

YP  =  SRDRLN/2 .  +  1.5  •  2.6 
MAPI  *  YANO( 1 :30) 

MAP 2  *  YANO(31 :60) 

WRITE  (11,1140)  XP,  YP,  90.,  0,1,  MAPI,  MAP 2 
XP  *  -0.1 
DO  94  1*1,5 


YP  «  <FL0AT<1AN<1 )>  •  THIN)  «  BRDRLN  /  <YMAX-YMIN)  ♦  0.7 
94  WRITE  <11,1130)  XP,  YP,  90.,  0.1,  10,  IAN<I) 

C 

C  DRAW  A  AT  THE  RANGE  CENTER  <COORDINATES  0,0) 

C 

XORG  *  <0.0  -  XM1N)  /  SCALE  ♦  0.0 
YORG  *  <0.0  -  YM1N)  /  SCALE  +  1.5 
WRITE  <11,1121)  XORG,  YORG-0.25,  XORG,  YORG+0.25, 

1  XORG-0.25,  YORG,  X0RG+0.25,  YORG 

C 

C  IF  EOF  THEN  END  THE  FRAME 

C 

WRITE  <11,1107) 

RETURN 

C 

c 

3001  FORMAT  <2F10.0) 

1101  FORMAT  < ' J08X  •,  A70) 

1102  FORMAT  < 1  PAGE  ',  F4.1) 

1104  FORMAT  < 'SI2X  ',  215,  2F5.1,  2<F  3.0,  15,  F10.0)) 

1105  FORMAT  < 1 BRDR 1 ) 

1106  FORMAT  <'LINE  O',  4F5.2,  19X,  *1') 

1107  FORMAT  <  'ENO ' ) 

1120  FORMAT  < ' SYMB  O',  4F5.3,  '  30*.  15X,  A30  / 

1  'ETCS  ',  25X,  1  30',  15X,  A30  / 

2  'ETCS  ',  25X,  •  10',  15X,  A10  > 

1121  FORMAT  < ' L I NE  O',  4F5.2,  19X,  '1'  ) 

1122  FORMAT  < 1 SYMB  O',  4F5.3,  '  30',  15X,  'SCALE:  1  INCH  »',  18, 

1  '  FEET  '  / 

2  'ETCS  ',  25X,  '  24',  15X,  '  ORIGIN:  LAT  ’,  A10/ 

3  'ETCS  ',  25X,  '  17',  15X,  '  LONG  ',  A10  ) 

1130  FORMAT  < ' SYMB  O',  4F5.2,  15,  15X,  110) 

1140  FORMAT  <’SYMB  O',  4F5.2,  '  30',  15X,  A30  / 

1  'ETCS  ',  25X,  '  30',  15X,  A30) 

ENO 


c 

e 

c 


!*■ 


SUBROUTINE  CPMXOP  (TITLE,  TOATE,  TT1ME,  LAT,  LONG) 

C 

C  ROUTINE  TO  OUTPUT  GPCP  CARDS  FOR  PLOTTING  SUPERSONIC 

C  FLIGHT  TRACKS 

C 

COMMON  /GRID/  GROXO,  XGS,  GRDXMX,  GRDYO,  YGS,  GRDYMX, 

1  LIMAXO,  LIHAYO,  LIMBXO,  LIMSYO, 

2  LIMAXl ,  L1MAY1 ,  L1MBX1,  LIMBY1 
C 

COMMON  /STATS/  STATFG,  BOOMFG,  MACHFG,  CONTFG,  BOOMVL, 

♦  MACNVL,  CONTVL(5,20),  CONTYP(5),  WIDTH,  FFT, 

+  SIGNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 

C 

INTEGER  CONTYP 

LOGICAL  FFT,  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 
C 

DIMENSION  1AN(5) 

C 

CHARACTER*(*)  TITLE,  TOATE,  TTIME,  LAT,  LONG 
CHARACTER  MAP1*30,MAP2*30,MAP3*10 
CHARACTER* 70  MAPANO,  XANO,  YANO 
C 


REAL 

CONTVL 

DATA 

TAN  /  -100000, 

•50000, 

0,  50000, 

100000  / 

DATA 

MAP* NO  /' 

1  / 

DATA 

XANO  /'RANG 

E  X  • 

/ 

COORD 

I  N  A  T  E 

IN  FEET'/ 

DATA 

YANO  /'RANG 

E  Y  - 

COORD 

I  N  A  T  E 

IN  FEET'/ 

C 

c 

FTDELM  »  999999. 

C 

WRITE  (11,1101)  TITLE 

PWIDTH  *  AMAXK8.0,  AMIN1  (WIDTH,  48.)) 

WRITE  (11,1102)  PWIDTH 
C 

SCALE  »  CONTVL (1,1)  /  12.0 
I SCALE  *  IFIX(SCALE  ♦  0.5) 

IGS  *  I FIX(XGS  ♦  0.5) 

XMIN  *  GRDXO  ♦  XGS/2.0 
XMAX  *  GROXMX  -  XGS/2.0 
YM1N  *  GRDYO  ♦  YGS/2.0 
YMAX  *  GRDYMX  -  YGS/2.0 

WRITE  (11,1104)  ISCALE,  [SCALE,  0.,  1.50,  XMIN,  IGS,  XMAX, 
1  YMIN,  IGS,  YMAX 


WRITE  (11,1105) 


C 

C 

c 


REWINO  UNIT  5  WITH  FLIGHT  TRACK  X/Y  COORDINATES 


REWIND  5 


C 

C 

C  KEEP  TRACK  Of  PREVIOUS  COORDINATES 

C 

c 

C  READ  NEXT  COORDINATE  PAIR 

C 

15  READ  (5,3001 ,END*100)  XI,  Y1 
C 

C  CONVERT  COORDINATES  TO  PLOTTER  INCHES  If  THIS 

C  COORDINATE  PAIR  IS  VALID,  ANO  LIMIT  TO  3OAR0ER 

C  (GPCP  INPUT  CARD  flELD  LENGTH  LIMITATION) 

C 

XI  *  AMAXKXMIN,  AM1NKX1,  XMAX)) 

T1  «  AMAXKTMIN,  AMINKY1,  YMAX)) 

XI  ■  (XI  •  XMIN)  /  SCALE 

Y1  «  (Y1  -  YMIN)  /  SCALE  ♦  1.5 

C 

C  OUTPUT  A  LINE  SEGMENT  ONLY  If  CURRENT  AND  PREVIOUS 

C  COORDINATES  ARE  VALID  ANO  AT  LEAST  ONE  IS  INSIDE  BOARDER 

C 

WRITE  (11,1121)  XI  ,  Y1  -0.25,  XI  ,  Y1  +0.25, 

1  XI  -0.25,  Y1  ,  XI  +0.25,  Y1 

GOTO  15 
C 

C  CALCULATE  HEIGHT  0f  'TITLE'  CHARACTERS  (MAX«0.25  IN) 

C  ANO  PLOT  TITLE 

C 

100  CONTINUE 

BRORLN  ■  (YMAX  •  YMIN)  /  SCALE 

CHGHT  »  AMINK0.25,  (BR0RLN-2.5)  /  80.) 

WRITE  (11,1120)  0.500,  1.000,  0.0,  CHGHT,  TITLE(1:30), 

1  TITLE(31 :6Q),  TITLE(61:70) 

C 

C  CALCULATE  HEIGHT  Of  'MAP  TYPE'  AND  'SCALE'  CHARACTERS 

C  (MAX >0.20  IN)  ANO  PLOT  2  LINES  Of  TEXT 

C 

CHGHT  *  AMIN1 (0.20,  (BR0RLN-3.0)  /  80.) 

MAPI  »  MAPANOI1 :30) 

MAP2  »  MAPANO(31:60) 

MAP3  «  MAPANO(61:70) 

WRITE  (11,1120)  1.000,  0.625,  0.0,  CHGHT,  MAPI, 

1  MAP2 ,  MAP3 

WRITE  (11,1122)  1.000,  0.250,  0.0,  CHGHT,  ISCALE,  LAT,  LONG 

C 

C  DRAW  80X  AROUND  TITLE  BLOCK 

C 

WRITE  (11,1121)  0.00,  1.50,  0.00,  0.00, 

1  0.00,  0.00,  BRORLN,  0.00, 

2  8RDRIN,  0.00,  BRORLN,  1.50, 

3  BRORLN- 1.5,  1.50,  BRORLN- 1.50,  0.0 
C 


C  PUT  TIC  HARKS  ON  MAP  EDGE 

C 

YTICO  *  1.5 
YTIC1  *  YTICO  ♦  0.15 
DO  82  1*1,9 

XTIC  *  FLOAT (I )  •  BRDRLN  /  10. 

WRITE  <11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
82  CONTINUE 
C 

YTICO  a  BRDRLN  ♦  1.5 
YTIC1  »  YTICO  -  0.15 
DO  84  1*1,9 

XTIC  *  FLQAT(I)  *  BRDRLN  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
84  CONTINUE 
C 

XT I CO  *  0.0 

XT  I  Cl  *  XT  I  CO  +  0.15 

DO  86  1*1,9 

YTIC  «  FLOAT ( I )  *  BRDRLN  /  10.  ♦  1.5 
WRITE  (11,1121)  XT  I CO,  YTIC,  XTIC1,  YTIC 
86  CONTINUE 
C 

XT  I  CO  *  BRDRLN 
XTIC1  «  BRORLN  •  0.15 
DO  88  1*1,9 

YTIC  «  FLOAT( I)  *  BRORLN  /  10.  ♦  1.5 
WRITE  (11,1121)  XT I CO ,  YTIC,  XTIC1,  YTIC 
88  CONTINUE 
C 

C  PUT  COORDINATE  ANNOTAION  ON  SIDES  OF  MAP 

C 

XP  *  BRDRLN/2.  •  2.6 
YP  *  BRDRLN  ♦  1.5  ♦  0.35 
MAPI  *  XANO(1 :30) 

MAP2  *  XANO(31 :60) 

WRITE  (11,1140)  XP,  YP,  0.,  0.1,  MAPI,  MAP2 
YP  a  BRORLN  +  1.6 
DO  92  1*1,5 

XP  *  (FLOAT(IANd))  •  XMIN)  *  BRDRLN  /  (XMAX-XMIN)  •  0.8 
92  WRITE  (11,1130)  XP,  YP,  0.,  0.1,  10,  IAN(I) 

C 

XP  *  -0.35 

TP  a  BRORLN/2.  ♦  1.5  •  2.6 
MAPI  ■  YANO(1:30) 

MAP2  *  YANO(31 :60) 

WRITE  (11,1140)  XP,  YP,  90.,  0.1,  MAPI,  MAP2 
XP  a  -0.1 
00  94  [=1,5 

YP  =  (FLOAT ( I AN < I ) )  •  YMIN)  *  BRDRLN  /  (YMAX-YMIN)  ♦  0.7 
94  WRITE  (11,1130)  XP,  YP,  90.,  0.1,  10,  !AN(I) 

C 

C  DRAW  A  **•  AT  THE  RANGE  CENTER  (COORDINATES  0,0) 

C 


XORG  -  <0.0  ■  XXIX)  /  SCALE  *  0.0 
YORG  «  <0.0  •  YMIN)  /  SCALE  ♦  1.5 
WRITE  <11,1121)  XORG,  YORG-0.25,  XORG,  YORG+0.25, 

1  XORG-0.25,  YORG,  XORG+C.25,  YORG 

C 

C  IF  EOF  THEM  END  THE  FRAME 

C 

WRITE  <11,1107) 

RETURN 

C 

C 

3001  FORMAT  <2F10.0) 


1101  FORMAT 

1102  FORMAT 

1104  FORMAT 

< 1 JOBX 

<  * PAGE 

< ‘SIZX 

',  A70) 

',  F4.1) 

,  215,  2F5.1, 

2<F10. 0,  15,  F10.0)) 

1105  FORMAT 

1106  FORMAT 

< 1 BROR ' 

< ‘LINE 

O',  4F5.2, 

19X,  *1') 

1107  FORMAT 

1120  FORMAT 

< 'END' ) 

< ' SYMB 

O',  4F5.3, 

•  30',  15X,  A30  / 

1 

•ETCS 

,  25X,  •  30 

,  15X,  A30  / 

2 

•ETCS 

,  25X,  •  10 

,  15X,  AID  ) 

1121  FORMAT 

< 'LINE 

O',  4F5.2, 

19X,  '1'  ) 

1122  FORMAT 

< '  SYMB 

O',  4F5.3, 

*  30*,  15X,  'SCALE: 

1  INCH  ■ 

1 

2 

•  FEET 

•ETCS 

•  / 

,  25X,  •  24 

,  15X,  •  ORIGIN:  LAT 

AID/ 

3 

•ETCS 

,  25X,  '  17 

,  15X,  1  LONG  •,  A10 

) 

1130  FORMAT 

< 1  SYMB 

O',  4F5.2, 

15,  15X,  110) 

1140  FORMAT 

< 1  SYMB 

01,  4F5.2, 

•  30' ,  15X,  A30  / 

1 

•ETCS 

,  25X,  '  30 

',  15X,  A30) 

c 

SUBROUTINE  CP8MTR  (TITLE,  TOATE,  TT1ME,  LAT,  LONG) 

C 

C  ROUTINE  TO  OUTPUT  GPCP  CARDS  FOR  PLOTTING  SONIC  BOOM 

C  FLIGHT  TRACKS 

C 

COMMON  /GRID/  GRDXO,  XGS,  GRDXMX,  GROYO,  YGS,  GRDYMX, 

1  LIMAXO,  L1MAY0,  LIMBXO,  LIMBYO, 

2  LIMAX1,  LIMAY1,  LIMBXl,  LIMBY1 
C 

COMMON  /STATS/  STATFG,  BOOMFG,  NACHFG,  CONTFG,  BOOMVL, 

♦  MACHVL,  CONTVL(5,20),  CONTYP(5),  WIDTH,  FFT, 

♦  SIGNAT,  RAYTRC,  SCRPAD,  SCRPSF,  SCRALL 
C 

INTEGER  CONTYP 

LOGICAL  FFT,  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 
C 

DIMENSION  IAN(S) 

C 

CHARACTER* (*)  TITLE,  TDATE,  TT1ME,  LAT,  LONG 
CHARACTER  MAP1*30,MAP2*30,MAP3*10 
CHARACTER*70  MAPANO,  XANO,  YANO 
C 

REAL  BOOMVL 

OATA  IAN  /  -100000,  -50000,  0,  50000,  100000  / 

DATA  MAPANO  /'FLIGHT  TRACK  SEGMENTS  OF  SOHIC  BOOM  PRODUCING  AIRCR 
1AFT  ACTIVITY1/ 

DATA  XANO  /'RANGE  X-COORDINATE  IN  FEET'/ 

DATA  YANO  /'RANGE  Y-COOROINATE  IN  FEET’/ 

C 
C 

FTDELM  *  999999. 

C 

WRITE  (11,1101)  TITLE 

PUIDTH  a  AMAX1  (8.0,  AMINKWIDTH,  48.)) 

WRITE  (11,1102)  PWIOTH 
C 

SCALE  »  BOOMVL  /  12.0 
ISCALE  «  !FIX(SCALE  ♦  0.5) 

IGS  a  I F I X (XGS  ♦  0.5) 

XMIN  a  GRDXO  ♦  XGS/2.0 
XMAX  a  GRDXMX  -  XGS/2.0 
YMIN  a  GRDYO  ♦  YGS/2.0 
YMAX  a  GROYMX  -  YGS/2.0 

WRITE  (11,1104)  (SCALE,  ISCALE,  0.,  1.50,  XMIN,  IGS,  XMAX, 

1  YMIN,  IGS,  YMAX 

C 

WRITE  (11,1105) 

REWINO  UNIT  4  WITH  FLIGHT  TRACK  X/Y  COORDINATES 


C 

c 

c 


REWINO  4 


c 

XI  ■  FTOELN 

Y1  *  0. 

C 

C  KEEP  TRACK  OF  PREVIOUS  COORDINATES 

C 

10  XO  «  XI 
TO  «  Y1 
C 

C  READ  NEXT  COORDINATE  PAIR 

C 

15  READ  (4,4001 ,ENO«10O)  XI,  Y1 
C 

C  CONVERT  COORDINATES  TO  PLOTTER  INCHES  IF  THIS 

C  COORDINATE  PAIR  IS  VALID,  AND  LIMIT  TO  BOARDER 

C  (CPCP  INPUT  CARO  FIELD  LENGTH  LIMITATION) 

C 

IF  (XI  .EO.  FTDELM)  GOTO  10 
XI  *  AMAXKXMIN,  AMIN1  (XI ,  XMAX)) 

Y1  *  AMAXKYMIN,  AMINKYl,  YMAX)) 

XI  *  (XI  •  XMIN)  /  SCALE 

Y1  «  (Y1  -  YMIN)  /  SCALE  +  1.5 

C 

C  OUTPUT  A  LINE  SEGMENT  ONLY  IF  CURRENT  AND  PREVIOUS 

C  COORDINATES  ARE  VALID  AND  AT  LEAST  ONE  IS  INSIDE  BOARDER 

C 

IF  (XO  .EQ.  FTDELM)  GOTO  10 

IF  (ABS(XI-XO)  .IT.  0.015  .AND.  ABS(YI-YO)  .IT.  0.015)  GOTO  15 
WRITE  (11,1106)  XO,  YO,  XI,  Y1 
GOTO  10 
C 

C  CALCULATE  HEIGHT  OF  'TITLE'  CHARACTERS  (MAX*0.25  IN) 

C  AND  PLOT  TITLE 

C 

100  CONTINUE 

BRORLN  *  (YMAX  '  YMIN)  /  SCALE 

CHGHT  *  AMINK0.25,  (BRORLN-2.5)  /  80.) 

WRITE  (11,1120)  0.500,  1.000,  0.0,  CHGHT,  TITLE(1:30), 

1  TITLE(31:60),  TITLE(61:70) 

C 

C  CALCULATE  HEIGHT  OF  'MAP  TYPE'  AND  'SCALE'  CHARACTERS 

C  (MAX*0.20  IN)  AND  PLOT  2  LINES  OF  TEXT 

C 

CHGHT  «  AMINK0.20,  (SRDRLN-3.0)  /  80.) 

MAPI  *  MAPANQO  :30) 

MAP2  *  MAPANO(31 :60) 

MAP3  *  MAPANO(61 :70) 

WRITE  (11,1120)  1.000,  0.625,  0.0,  CHGHT,  MAPI, 

1  MAP2,  MAP3 

WRITE  (11,1122)  1.000,  0.250,  0.0,  CHGHT,  ISCALE,  LAT,  LONG 

C 

C  DRAW  BOX  AROUNO  TITLE  BLOCK 

C 

WRITE  (11,1121)  0.00,  1.50,  0.00,  0.00, 


1  0.00,  0.00,  MORIN,  0.00, 

2  BRORLN,  0.00,  BRDRIN,  1.50, 

3  BRORLN- 1.5,  1.50,  BRDRLN- 1 .50,  0.0 

C 

C  PUT  TIC  MARKS  ON  MAP  EDGE 

C 

YTICO  «  1.5 
YTIC1  «  YTICO  ♦  0.15 
DO  82  1-1,9 

XTIC  ■  FLOAT ( I)  *  BRDRLN  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
82  CONTINUE 
C 

YTICO  *  BRORLN  *  1.5 
YTIC1  «  YTICO  •  0.15 
DO  84  1-1,9 

XTIC  -  FLOAT ( 1 )  *  BRDRLN  /  10. 

WRITE  (11,1121)  XTIC,  YTICO,  XTIC,  YTIC1 
34  CONTINUE 
C 

XT I CO  *  0.0 

XT  I  Cl  «  XT  I  CO  ♦  0.15 

DO  86  1-1,9 

YTIC  •  FLOAT ( I )  *  BRORLN  /  10.  ♦  1.5 
WRITE  (11,1121)  XTICO,  YTIC,  XTIC1 ,  YTIC 
86  CONTINUE 
C 

XTICO  «  BRORLN 

XT  I Cl  »  BRORLN  -  0.15 

DO  88  1-1,9 

YTIC  »  FLOAT(I)  *  BRORLN  /  10.  ♦  1.5 
WRITE  (11,1121)  XTICO,  YTIC,  XT  I Cl,  YTIC 
88  CONTINUE 
C 

C  PUT  COORDINATE  ANNOTAION  ON  SIDES  OF  MAP 

C 

XP  «  BRORLN/2.  •  2.6 
YP  «  BRDRLN  ♦  1.5  ♦  0.35 
MAPI  -  XANO( 1:30) 

MAP2  «  XANO(31:60) 

WRITE  (11,1140)  XP,  YP,  0.,  0.1,  MAPI,  MAP2 
YP  ■  BRORLN  ♦  1.6 
DO  92  1-1,5 

XP  «  (FLOAT(IANd))  -  XMIN)  *  BRDRLN  /  (XMAX-XMIN)  -  0.8 
92  WRITE  (11,1130)  XP,  YP,  0.,  0.1,  10,  IAN(I) 

C 

XP  »  -0.35 

YP  *  8RDRLN/2.  ♦  1.5  •  2.6 
MAPI  a  YANO(1 :30) 

MAP2  -  YANO(31 :60) 

WRITE  (11,1140)  XP,  YP,  90.,  0.1,  MAPI,  MAP2 
XP  -  -0.1 
DO  94  1-1,5 

TP  -  (FLOAT( IAN( I ) )  -  YMIN)  »  BRORLN  /  (YMAX-YMIN)  +0.7 


94  WRITE  (11,1130)  XP,  YP,  90.,  0.1,  10,  IAM(I) 


C  DRAW  A  AT  THE  RANGE  CENTER  (COORDINATES  0,0) 

C 

XORG  *  (0.0  -  XMIN)  /  SCALE  +  0.0 
YORG  «  (0.0  •  YHIN)  /  SCALE  ♦  1.5 
C 

WRITE  (11,1121)  XORG,  YORG -0.25 ,  XORG,  YORG+O.25, 

1  XORG'O.25,  YORG,  X0RG+0.25,  YORG 

C 

C  IF  EOF  THEN  ENO  THE  FRAME 

C 

WRITE  (11,1107) 

RETURN 

C 

C 

4001  FORMAT  (2F10.0) 

1101  FORMAT  OJOeX  ',  A70) 

1102  FORMAT  (‘PAGE  ',  F4.1) 

1104  FORMAT  CSIZX  ',  215,  2F5.1,  2(F10.0,  15,  F10.0)) 

1105  FORMAT  CBROR') 

1106  FORMAT  CLINE  O',  4F5.2,  19X,  '1') 

1107  FORMAT  ('END') 

1120  FORMAT  CSYMB  O',  4F5.3,  1  30',  15X,  A30  / 

1  'ETCS  ',  25X,  •  30',  15X,  A30  / 

2  'ETCS  ',  25X,  '  10',  15X,  A10  ) 

1121  FORMAT  CLINE  O',  4F5.2,  19X,  *1'  ) 

1122  FORMAT  CSYMB  O',  4F5.3,  '  30',  15X,  'SCALE:  1  INCH  * 

1  •  FEET  •  / 

2  'ETCS  ',  25X,  '  24',  15X,  '  ORIGIN:  LAT  ',  A10/ 

3  'ETCS  ',  25X,  •  17',  15X,  1  LONG  ',  A10  ) 

1130  FORMAT  CSYMB  O’,  4F5.2,  15,  15X,  110) 

1140  FORMAT  CSYMB  O',  4F5.2,  '  30',  15X,  A30  / 

1  'ETCS  ',  25X,  •  30',  15X,  A30) 

ENO 


BLOCK  DATA  DICK 


COMMON  /GRID/  GRDXO,  XGS,  GRDXMX,  GRDYO,  YGS,  GRDYMX, 

1  L1MAXO,  l! MAYO,  L1MBXO,  L1MBYO, 

2  LIMAX1,  L1MAY1 ,  IIMBX1 ,  LIMBY1 

DATA  GRDXO,  XGS,  GRDXMX  /  -126250.,  2500.,  126250.  / 
DATA  GRDYO,  YGS,  GRDYMX  /  -126250.,  2500.,  126250.  / 
END 


MODULE  NAME:  SCHPACK 
MOOULE  TYPE:  PACKAGE 

OVERVIEW: 

THIS  PACKAGE  IS  USED  TO  PERFORM  THE  PROCESS  OF  SEARCHING 
THE  DATA  TABLES  CREATED  DURING  THE  PARSE  STAGE.  THIS  SEARCH 
IS  USED  TO  FIND  RECORDS  OF  SUBSONIC  AND  SUPERSONIC  FLIGHT  DATA 
RECOROS  IN  THE  LIBRARY  FILE  BY  FINOING  THEIR  LOCATION  THROUGH 
THE  USE  OF  AN  INDEX  FILE.  THIS  INDEX  FILE  IS  SIMILAR  TO  A  CARD 
CATALOG. 

INTEFACE: 

GETREC  C  PI,  P2,  P3  ) 

PI  (INTEGER]  POINTER  TO  THE  STARTING  RECORD 
P2  (INTEGER]  TOTAL  OF  RECORDS  STARTING  AT  PI 
P3  (LOGICAL]  FLAG  SIGNALING  NO  MORE  RECORDS  LEFT 

INTERNAL  SUBROUTINES  t  FUNCTIONS 

FILBUFO  ;  READS  ON  RECORO  FROM  THE  INOEX  FILE  INTO  A  BUFFE 
STRMCHO  ;  RETURNS  TRUE  IF  A  STRING  MATCHES  WITH  TABLE  STR 
INTMCHO  ;  RETURNS  TRUE  IF  AN  INT.  MATCHES  WITH  TABLE  INTE 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  23-OCT-85 

REVISIONS  : 


MOOULE  NAME:  SCHPACKNFILBUF 

MOOULE  TYPE:  CHARACTER  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  READ  IN  ON  RECORD  FROM  T 
INOEX  FILE.  IF  THERE  ARE  NO  MORE  RECORDS  THEN  THE  FLAG  .ENOREC. 
SET  TRUE. 

INVOCATION: 

(X  *  ]  FIL8UF  (  PI,  P2,  P3,  Pi  ) 

PI  ::*  (INTEGER]  CURRENT  RECORD  NUMBER 

P2  ::*  (INTEGER]  NUMBER  OF  RECORDS  IN  INOEX  FILE 


P3  [INTEGER]  UNIT  NUMBER  CORRESPONDING  TO  INDEX  FIL 

P4  [LOGICAL]  FLAG  SIGNALING  THE  ENO  OF  RECORDS 

VAR1A8LE  DICTIONARY: 

ENDREC  ;  P4 
IDXFIL  ;  P3 
NUMREC  ;  P2 
RECNUM  ;  PI 

CALLER  NOOULES: 

[SUBROUTINE]  SCHPACtCNGETREC 

CALLED  MODULES: 

...NONE... 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22-OCT-85 

REVISIONS  : 

CHARACTER^*)  FUNCTION  FILBUF< 

♦  RECNUM,  NUMREC,  IDXFIL,  ENDREC) 

INTEGER  RECNUM,  NUMREC,  IDXFIL 
LOGICAL  ENDREC 

IF  (RECNUM. LE. NUMREC)  THEN 
RECNUM  *  RECNUM  ♦  1 

REAO( IDXFIL, FMT=" (A) ' , REC=RECNUM)  FILBUF 
ELSE 

ENDREC  *  .TRUE. 

ENO  IF 

RETURN 

ENO 


MODULE  NAME:  SCHPACK\STRMCH 

MODULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USED  TO  SEE  IF  A  STRING  PASSED 
IN  MATCHES  ANY  STRING  IN  THE  CURRENT  ROW  OF  A  TABLE  PASSED  IN. 
IF  ‘ALL1  IS  FOUND  THEN  THE  SEARCH  IS  CONSIDERED  SUCCESSFUL. 


INVOCATION: 

CX  *  3  STRMCH  (  PI,  P2,  P3,  P4,  P5  ) 

PI  (CHARACTER*!*)!  STRING  TO  SEARCH  FOR 

P2  (INTEGER!  REPETITION  BEING  TESTED 

P3  ::■  (CHARACTER* (*)  <P4,P5)3  TABLE  TO  SEACH  THROUGH 
P4  (INTEGER!  BOUNO  FOR  THE  ROW  SIZE 

PS  (INTEGER!  BOUNO  FOR  THE  COLUMN  SIZE 

VARIABLE  DICTIONARY: 


COL 

CURREP 

EXTLOP 

MXCOL 

MXROU 

SRCFOR 

TABLE 


CURRENT  COLUMN  IN  THE  SEARCH  TABLE 
P2 

SYMBOL  REPRESENTING  STATEMENT  LABEL  2DO 

PS 

P4 

PI 

P3 


CALLER  MOOULES: 


(SUBROUTINE!  SCHPACKXGETREC 
CALLED  MOOULES: 


...HONE. 


PROGRAMMER:  BRUCE  8.  LACEY 
DATE  :  22-OCT-S5 

REVISIONS  : 


LOGICAL  FUNCTION  STRMCH ( 

SRCFOR,  CURREP,  TABLE,  MXROW,  MXCOL) 

INTEGER  CURREP,  MXROW,  MXCOL,  COL,  EXTLOP 
CHARACTERS*)  SRCFOR,  TABLE  (MXROW,  MXCOL) 

ASSIGN  200  TO  EXTLOP 


STRMCH  *  .FALSE. 


00  100  COL  «  1,  NXCOL 

IF  ( (TABLE (CURREP, COL) .EQ. 1  ALL 1 ) .OR. 

♦  ( TABLE (CURREP, COL ).£O.SRCFOR))  THEM 

IF  (TABLE(CURREP,COL).ME. 1  ')  THEM 
STRMCH  «  .TRUE. 

GO  TO  EXTLOP 
END  IF 
END  IF 

100  CONTINUE 

C  EXTLOP: 

200  RETURN 

ENO 


MOOULE  NAME:  SCHPACXV INTMCH 

MOOULE  TYPE:  LOGICAL  FUNCTION  SUBROUTINE 

OVERVIEW: 

THIS  FUNCTION  SUBROUTINE  IS  USEO  TO  TEST  IF  AN  INTEGER  PASSE 
IN  HATCHES  AN  INTEGER  IN  THE  CURRENT  ROW  OF  THE  TABLE  PASSED  IN. 
IF  9999  IS  FOUNO  THEN  THE  TEST  IS  CONSIDERED  SUCCESSFUL. 

INVOCATION: 

tX  ■  ]  INTMCH  <  PI,  P2,  P 3,  P4,  P5,  P6  > 

PI  [INTEGER]  VALUE  TO  BE  TESTED 
P2  ::■  [INTEGER]  ROW  CURRENTLY  BEING  TESTED 
P3  ::■  [INTEGER(P5,P6)]  TABLE  FOR  LOWER  BOUND 
P4  ::*  [1NTEGER(P5,P6)3  TABLE  FOR  UPPER  BOUND 
PS  ::»  [INTEGER]  LOWER  BOUND  FOR  P3  ANO  P4 
P6  ::■  [INTEGER]  UPPER  BOUND  FOR  P3  AND  P4 

VARIABLE  DICTIONARY: 

COL  ;  CURRENT  COLUMN  IN  SEARCH  TABLES 
CURREP  ;  P2 
ETABLE  ;  P3 

EXTLOP  ;  SYMBOL  REPRESENTING  STATEMENT  LABEL  200 

MXCOL  ;  P6 

HXROU  ;  P5 

SRCFOR  ;  PI 

STABLE  ;  P4 

CALLER  MODULES: 

[SUBROUTINE]  SCHPACJC\GETREC 

CALLED  MOOULES: 

...NONE... 

PROGRAMMER:  BRUCE  3.  LACEY 
DATE  :  22 -OCT -85 

REVISION  : 

LOGICAL  FUNCTION  INTMCH ( 

SRCFOR,  CURREP,  STABLE,  ETABLE,  MXROU,  MXCOL) 

INTEGER  SRCFOR,  CURREP,  MXROW,  MXCOL,  EXTLOP 
INTEGER  COL,  LOOP 

INTEGER  ST ABLE (MXROW, MXCOL),  ETABLE(MXROW, MXCOL) 


ASSIGN  100  TO  LOOP 


ASSIGN  200  TO  EXT l OP 


C  LOOP: 
100 


C  EXT LOP: 
200 


INTHCH  «  .FALSE. 

IF  (STA8LE<CURR£P,1). £0.9999)  THEN 
INTHCH  »  .TRUE. 

ELSE 

COL  *  1 

I F<  CSRCFOR . GE . ST ABLE  <  CURREP , COL )) .AND . 
(SRCFOR . LE . ETA8LE ( CURREP , COL ) ) )  THEN 
INTHCH  «  .TRUE. 

GO  TO  EXTLOP 
END  IF 

COL  *  COL  ♦  1 

IF  (COL.LE.MXCOL)  GO  TO  LOOP 

ENO  IF 
RETURN 


END 


MODULE  NAME:  SCHPACKNGETREC 
MOOULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  SERARCH  THE  INDEX  FILE  ACCORDING 
THE  USER  SPECIFICATIONS  STORED  DURING  THE  PARSE  STAGE.  WHEN  INVO 
THIS  SUBROUTINE  WILL  READ  RECORDS  FROM  THE  INDEX  FILE  UNTIL  A  MAT 
IS  FOUND.  WHEN  A  MATCH  IS  FOUND  THE  SUBROUTINE  WILL  RETURN  THE 
STARTING  RECORD  NUMBER  AND  THE  NUMBER  OF  RECOROS  OCCUR  I NG  AFTER 
THE  STARTING  RECORD.  IF  A  MATCH  IS  NOT  FOUND  THEN  THE  ENO  OF  REC 
FLAG  .ENOREC.  IS  SET  TRUE. 

INVOCATION: 

[CALL]  GETREC  <  PI,  P2,  P3,  P4  ) 

PI  [INTEGER]  STARTING  RECORD  NUMBER 

P 2  ::«  [INTEGER]  COUNT  OF  RECORDS  FOLLOWING  PI 
P3  [INTEGER]  COUNT  OF  SUPERSONIC  RECORDS 

P4  [LOGICAL]  FUG  SIGNALING  THE  END  OF  RECORDS 

VARIABLE  DICTIONARY: 


ARCRFT 

CURREC 

ENDATE 

ENOREC 

ENT  1 ME 

IDXFIL 

INTDAT 

LOOP 

MSSNS 

MXDATE 

MXMSSN 

MXPLNS 

MXREPS 

MXSITE 

MXTIME 

NUMREC 

NUMREP 

REC8UF 

RECTOT 

SITES 

STREC 

STTIME 

TAILNM 

TBLIOX 

TIME1 

TIME2 


TABLE  CONTAINING  AIRCRAFT  TYPES 

THE  CURRENT  RECORD  NUMBER  FROM  FILE  'INDEX' 

TABLE  CONTAINING  THE  END  DATES 
P3 

TABLE  CONTAINING  THE  END  TIMES 

UNIT  NUMBER  FOR  THE  INDEX  FILE 

INTEGER  REPRESENTING  YYMMDD  DATE 

SYMBOL  REPRESENTING  STATEMENT  LABEL  1 

TABLE  CONTAINING  THE  MISSION/EXERCISE  NAMES 

MAXIMUM  NUMBER  OF  DATE  ALLOWED 

MAXIMUM  NUMBER  OF  MISSION  ALLOWED 

MAXIMUM  NUMBER  OF  AIRCRAFT  ALLOWED 

MAXIMUM  NUMBER  OF  REPETITIONS  OF  SITE  CARDS  ALLOWE 

MAXIMUM  NUMBER  OF  SITES  LOCATIONS  ALLOWED 

MAXIMUM  NUMBER  OF  START/ENO  TIMES  ALLOWED 

NUMBER  OF  RECORDS  IN  THE  INDEX  FILE 

NUMBER  OF  REPETITIONS  STORED  DURING  PARSE 

BUFFER  TO  HOLD  ONE  RECORD  FROM  FILE  ' INOEX' 

P2 

TABLE  CONTAINING  THE  SITE  LOCATIONS 
PI 

TABLE  CONTAINING  THE  STARTING  TIMES 
TABLE  CONTAINING  THE  AIRCRAFT  TAIL  NUMBERS 
CURRENT  REPETITION  BEING  COMPARED 
STARTING  TIME  FROM  RECORD  IN  'INDEX' 

ENOING  TIME  FROM  RECORD  IN  'INDEX' 


CALLER  MCOULES: 


MAIN  DRIVER  ROUTINE 
CALLED  MODULES: 

[SUBROUTINE  FUNCTION]  SCHPACK\FILBUFO 
[SUBROUTINE  FUNCTION]  SCHPACK\SCHMCHO 
[SUBROUTINE  FUNCTION]  SCHPACK\INTHCH( ) 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22 -OCT -85 

REVISIONS  : 

SUBROUTINE  GETRECCSTREC,  RECTOT,  SUPREC,  ENDREC,  ID 

EXTERNAL  STRMCH,  INTMCH,  FILBUF 

PARAMETER (HXD ATE *10,  MXMSSN*10,  MXPLNS310, 

MXREPS*5  ,  MXS1TE320,  MXTIME310) 

COMMON  /CHRTA8S/  ARCRFT,  MSSNS,  SITES,  TAILNM 

COMMON  /INTTABS/  ENOATE,  ENTIME,  STDATE,  STTIME,  MUMREP 

INTEGER  ENOATE (MXREPS, MXDATE) 

INTEGER  ENTIM€(MXREPS,MXTIM6) 

INTEGER  STDATE(MXREPS , MXOATE ) 

INTEGER  STT I ME (MXREPS , MXT IME ) 

INTEGER  NUMREP,  STREC,  RECTOT,  CURREC,  INTDAT,  LOOP 
INTEGER  TIME1,  TIME2,  IDXFIL,  NUMREC,  TBLIDX,  SUPREC 

CHARACTER'S  ARCRFT (MXREPS , MXPLNS ) 

CHARACTER'D  MSSNSCMXREPS.MXMSSN) 

CHARACTER* 10  S I TES(MXREPS , MXS I TE ) 

CHARACTER'S  TA1 LNM(MXREPS , MXPLNS ) 

CHARACTER'98  FILBUF,  REC8UF 

LOGICAL  ENDREC,  STRMCH,  INTMCH 

SAVE  CURREC 

DATA  IDXFIL  /I/ 

DATA  CURREC  /0/ 

ASSIGN  1  TO  LOOP 


IF  (CURREC. LE.D  THEN 

READ  THE  HEADER  RECORD  TO  GET  THE  NUMBER  OF  RECORDS. 
CURREC  3  CURREC  ♦  1 

READ( IDXFIL , FMT3' ( 16) ’ ,REC=CURREC)  NUMREC 
ENDREC  3  .FALSE. 


ENO  IF 


T8LIDX  *  0 


C- •  GET  THE  STARTING  RECORD 

REC8UF  *  F I L8UF < OJRREC , NUHREC , 1 DXF I L , EHDREC ) 

C  LOOP: 

1  IF  (ENOREC.EOV. .TRUE. )  RETURN 

T8L10X  *  TBLIDX  ♦  1 
IF  ( T8L I DX . GT . NUHREP )  THEN 
C- -  READ  IN  ANOTHER  RECORD  FOR  TESTING 

REC8UF  «  FI LBUF ( CURREC , NUMREC , IDXF I L , EHDREC) 

T8LIDX  «  1 
ENO  IF 

CHECK  IF  SITE  LOCATIONS  HATCH 

IF  (STRHCH (REC8UF ( 27 : 36 ) , TBL IDX , SI TES , MXREPS , MXS I TE ) 

. EQV . . TRUE . )  THEN 
CHECK  IF  THE  HI  SSI ON  NAHES  HATCH 

1 F  (STRHCH(RECBUF( 1 : 16) , TBLIDX , HSSNS , HXREPS , MXMSSN ) 
.EQV.. TRUE.)  THEN 
C-  CHECK  IF  THE  DATE  INTERVALS  CORRESPOND. 

C-  FIRST  CONVERT  THE  OATE  TO  YYHHOD  INTEGER 

READ ( REC8UF  < 1 7 : 1 8) , FMT» • { 1 2 ) • )  I NTDAT 
INTOAT  »  INTOAT  *  100 
READ(RECSUF(20:21 ), FMT**<I2) 1 )  I 
INTOAT  *  INTOAT  ♦  I 
READ(REC8UF(23:24),FHT*,(I2)1 )  I 
INTOAT  *  INTOAT  *  (I  *  10000) 

I F  ( I NTHCH< I NTDAT , TBL IDX , STDATE , ENOATE .HXREPS , MXOATE ) 
♦  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  TIHE  INTERVALS  CORRESPOND.  • 

READ(REC8UF(37:40) , FMT»‘ < 14) 1 )  TIHE1 
READ(RECBUF(45:48), FMT=‘ ( 14) 1 )  TIHE2 
IF  ( ( I NTHCH ( T I ME 1 , TBL I DX , STT I HE , ENT  I ME , 

HXREPS , HXT I HE ) . EO V . . TRUE . ) . OR . 
(INTMCH<TIHE2,TBLI0X,STTIHE,ENTIME, 

HXREPS, HXT I HE). EQV.. TRUE.))  THEN 
CHECK  IF  AIRCRAFT  TYPES  HATCH. 

IF  (STRMCH<REC8UF(55:60), TBLIDX, ARCRFT, 

HXREPS, HXPLNS). EQV. .TRUE.)  THEN 
c-  CHECK  IF  THE  AIRCRAFT  TAIL  NUMBERS  MATCH 

IF  (STRMCH(REC8UF (61:68), TBL IDX, TAILNM, 

+  MXREPS, MXPLNS5. EQV.. TRUE.)  THEN 

C-  UE  HAVE  A  SUCESSFUL  HATCH 

REA0(RECSUF<69:78) , FMT=' ( 110)')  STREC 
READ(RECSUF(79:38), FMT*' (110) ' )  RECTOT 
REA0(REC8UF(89:98) , FMT=' (110)')  SUPREC 


II  *  QJRREC 
RETURN 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 
ELSE 

GO  TO  LOOP 
ENO  IF 


*MSa:S»XS3SSSSS=323SSS3Sn33SS2S3SUSaa»Ma3S3SSX3»Sl»St»SSSXSS3=l 

* . »»>  ENO  SCHPACK  ««< . 

•lXXaX312333X2XllX33XX333X3XX31X33IX321113313133XXXI3333X3331133X33XXI23 


ENO 


MODULE  NAME:  SCHPACKXGETOMC 
MODULE  TYPE:  SUBROUTINE 


OVERVIEW: 

THIS  SUBROUTINE  IS  USED  TO  SERARCH  THE  IHOEX  FILE  ACCORDING 
THE  USER  SPECIFICATIONS  STORED  DURING  THE  PARSE  STAGE.  WHEN  INVO 
THIS  SUBROUTINE  WILL  READ  RECORDS  FROM  THE  INDEX  FILE  UNTIL  A  MAT 
IS  FOUND.  WHEN  A  MATCH  IS  FOUND  THE  SUBROUTINE  WILL  RETURN  THE 
STARTING  RECORD  NUMBER  AND  THE  NUMBER  OF  RECORDS  OCCUR I NG  AFTER 
THE  STARTING  RECORD.  IF  A  MATCH  IS  NOT  FOUND  THEN  THE  END  OF  REC 
FLAG  .ENOREC.  IS  SET  TRUE. 


INVOCATION: 

[CALL!  GETINX  <  PI,  P2,  P3,  P4  ) 

PI  CINTEGER1  STARTING  RECORD  NUMBER 
P2  ::*  (INTEGER]  COUNT  OF  RECORDS  FOLLOWING  PI 
P 3  (INTEGER]  COUNT  OF  SUPERSONIC  RECORDS 

P4  (LOGICAL]  FUG  SIGNALING  THE  END  OF  RECORDS 

VARIABLE  DICTIONARY: 


ARCRFT 

CURREC 

ENOATE 

ENOREC 

ENT 1 ME 

1DXFIL 

INTDAT 

LOOP 

MSSNS 

MXDATE 

MXMSSN 

MXPLNS 

MXREPS 

MXSITE 

MXTIME 

NOPREC 

NUMREC 

NUMREP 

OPR 

RECBUF 

RECTOT 

SITES 

STREC 

STTIME 

SUPREC 

TAILNM 

T8LI0X 


TABLE  CONTAINING  AIRCRAFT  TYPES 

THE  CURRENT  RECORO  NUMBER  FROM  FILE  'INDEX'  . 

TABLE  CONTAINING  THE  END  DATES 
P3 

TABLE  CONTAINING  THE  END  TIMES 

UNIT  NUMBER  FOR  THE  INDEX  FILE 

INTEGER  REPRESENTING  TYMMOD  DATE 

SYMBOL  REPRESENTING  STATEMENT  UBEL  1 

TABLE  CONTAINING  THE  MISSION/EXERCISE  NAMES 

MAXIMUM  NUMBER  OF  OATE  ALLOWED 

MAXIMUM  NUMBER  OF  MISSION  ALLOWED 

MAXIMUM  NUMBER  OF  AIRCRAFT  ALLOWED 

MAXIMUM  NUMBER  OF  REPETITIONS  OF  SITE  CARDS  ALLOWS 

MAXIMUM  NUMBER  OF  SITES  LOCATIONS  ALLOWED 

MAXIMUM  NUMBER  OF  START/END  TIMES  ALLOWED 

NUMBER  OF  OVERPRESSURE  RECORDS. 

NUMBER  OF  RECORDS  IN  THE  INDEX  FILE 
NUMBER  OF  REPETITIONS  STORED  DURING  PARSE 
FLAG  .TRUE.  IF  THE  TRACK  CONTAINS  OVERPRESSURE  REC 
BUFFER  TO  HOLD  ONE  RECORD  FROM  FILE  'INDEX' 

P2 

TABLE  CONTAINING  THE  SITE  LOCATIONS 
PI 

TABLE  CONTAINING  THE  STARTING  TIMES 
STARTING  OVERPRESSURE  RECORD. 

TABLE  CONTAINING  THE  AIRCRAFT  TAIL  NUMBERS 
CURRENT  REPETITION  BEING  COMPARED 


T1ME1  ;  STARTING  TIME  FROM  RECORD  IN  'INDEX' 

TIME2  ;  ENOING  TIME  FROM  RECORD  IN  'INDEX' 

t 

CALLER  MODULES: 

MAIN  DRIVER  ROUTINE 
CALLED  MOOULES: 

[SUBROUTINE  FUNCTION]  SCHPACK\FILBUF<) 

[SUBROUTINE  FUNCTION]  SCHPACK\SCHMCH() 

[SUBROUTINE  FUNCTION]  SCHPACXUNTMCHO 

PROGRAMMER:  BRUCE  B.  LACEY 
DATE  :  22- OCT -85 
REVISIONS  : 

SUBROUTINE  G£TINX<STREC,  RECTOT,  SUPREC,  ENDREC,  II,  NOPREC, 
OPR) 

EXTERNAL  STRMCH ,  INTMCH,  F1LBUF 

PARAMETER(MXDATE*10,  MXMSSN*10,  MXPLNS*10, 

MXREPS-5  ,  MXSITE*20,  MXTIME=10) 

COMMON  /CHRTABS/  ARCRFT,  MSSNS,  SITES,  TAILNM 

COMMON  /INTTABS/  ENOATE,  ENT1ME,  STDATE ,  STTIME,  NUMREP 

INTEGER  ENDATE(MXREPS, MXD ATE ) 

INTEGER  ENTIME(MXREPS,MXTIME) 

INTEGER  STDATE(MXREPS , MXDATE 5 
INTEGER  STT I ME ( MXREPS , MXT I  ME ) 

INTEGER  NUMREP,  STREC,  RECTOT,  CURREC,  INTDAT,  LOOP 
INTEGER  TIME1,  TIME2,  IDXFIL,  NUMREC,  TBLIDX,  SUPREC 

CHARACTER*6  ARCR  FT (MXREPS , MXPLNS ) 

CHARACTERS  MSSNS  ( MXREPS ,  MXMSSN ) 

CHARACTERS  SITES(MXREPS,MXSITE) 

CHARACTER'S  TAILNMCMXREPS, MXPLNS) 

CHARACTER'110  FILBUF,  RECBUF 

LOGICAL  ENDREC,  STRMCH,  INTMCH,  OPR 

SAVE  CURREC 

DATA  CURREC  /0/ 

DATA  IDXFIL  /5 V 
ASSIGN  1  TO  LOOP 


IF  (CURREC. LE.1)  THEN 

READ  THE  HEADER  RECORO  TO  GET  THE  NUMBER  OF  RECORDS. 
CURREC  *  CURREC  ♦  1 

REAO( IDXFIL, FMT« ' (4X, 16) ' ,REC=CURREC)  NUMREC 


ENOREC  ■  .FALSE. 

NUHREC  >  RUHR EC  -  1 
END  IF 

TBLIDX  «  0 

C- -  GET  THE  STARTING  RECORD 

REC8UF  *  F I L8UF(CURREC, NUHREC, IDXFIL.ENDREC) 

C  LOOP: 

1  IF  (ENDREC. EQV.. TRUE.)  RETURN 

TBLIDX  ■  TBLIDX  *  1 
IF  (TBLIDX. GT.NUMREP)  THEN 
C- -  READ  IN  ANOTHER  RECORD  FOR  TESTING 

RECSUF  ■  FI LBUF ( CURREC , NLMREC , IDXF I L , ENDREC) 

TBLIDX  »  1 
END  IF 

C--  CHECK  IF  SITE  LOCATIONS  MATCH 

IF  (STRMCH(R£C8UF(27:36), TBLIDX, SITES, MXREPS, MXSITE) 

♦  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  MISSION  NAMES  MATCH 

I F  ( STRMCH (REC8UF ( 1 : 16 ) , TBL IDX , MSSNS , MXREPS , MXMSSN ) 

♦  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  DATE  INTERVALS  CORRESPOND. 

C-  FIRST  CONVERT  THE  DATE  TO  YYMMDD  INTEGER 

READ(REC8UF(17:18),FMT«'(I2>')  INTDAT 
INTDAT  *  INTOAT  •  100 
REAO(REC8UF(20:21 ), FMT»*(I2) 1 )  I 
INTOAT  *  INTDAT  ♦  I 
REA0(REC8UF(23:24),FMT*'(I2)')  I 
INTDAT  *  INTDAT  ♦  (I  *  10000) 

1 F  ( I NTMCH( INTOAT , TBL 1 DX, STDATE , ENDATE , MXREPS , MXDATE ) 
+  .EQV.. TRUE.)  THEN 

C-  CHECK  IF  THE  TIME  INTERVALS  CORRESPOND. 

READ(REC8UF(37:40),FMT»' (14) 1 )  TIME1 
READ ( RECBUF (45:48), FMT » •  ( 1 4  )  1 )  TIME2 
IF  ((INTMCH(TIME1, TBLIDX, STTIME.ENTIME, 

MXREPS, MXT1ME). EQV.. TRUE.). OR. 

( I  NTMCH(T  I ME2 ,  T8L  IDX ,  STT IME ,  ENT  IME , 

MXREPS , MXT I ME ) . EQV . .TRUE. ))  THEN 
CHECK  IF  AIRCRAFT  TYPES  MATCH. 

IF  <STRMCH(REC8UF(55:60),TBLIDX,ARCRFT, 

MXREPS, MXPLNS). EQV. .TRUE.)  THEN 
C-  CHECK  IF  THE  AIRCRAFT  TAIL  NUMBERS  MATCH 

IF  (STRMCH (RECBUF (61 :68) , TBLIDX,TAI LNM, 

♦  MXREPS, MXPLNS). EQV.. TRUE.)  THEN 


ue  HAVE  A  SUCESSFUL  HATCH 
READ(REC8UF(69:78),  FHT*1 (110) 1 )  STREC 
R£AD(R£CBUF(79:88) , FHT*1 ( 110)')  RECTOT 
R£A0(R£C8(JF(89:98) ,  FHT * 1  ( 110)')  SUPREC 
R£AD(REC8UF(99: 108) , FHT*1 ( I 10) 1 )  NOPREC 
READ (REC8UF( 109: 109), FHT*1 (11 ) 1 )  OPR 
II  *  CLIRREC 
RETURN 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 
ELSE 

GO  TO  LOOP 
END  IF 


ENO 


PROGRAM  STOREC (OUTPUT , TAPE6*0UTPUT , TAPE 11*0) 


THIS  SUBROUTINE  IS  DESIGNED  TO  STORE  NEEDED  VARIABLES  IN 
A  TEMPORARY  FILE  SO  THE  PLOTING/RAYTRACING  CAN  BE  RUN  AS 
A  TWO  STEP  PROCESS. 


COMMON  /CHRTABS/  ARCRFT,  MSSNS,  SITES,  TAILNM 
COMMON  /INTTA8S/  ENDATE,  ENTIME,  STDATE,  STTIME,  NUMREP 

COMMON  /STATS/  STATFG,  BOOMFG,  MACHFG,  CONTFG,  BOOMVL, 

1  MACHVL,  CONTVL,  CONTYP,  WIDTH,  FFT, 

2  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 

INTEGER  ENOATE(S, 10),  ENTIMECS.10),  STDATE(5,10) 

INTEGER  STTIME(5,10),  C0NTYP<5),  NUMREP 

REAL  CONTVL(5,20),  BOOMVL,  MACHVL,  WIDTH 

LOGICAL  STATFG,  800MFG,  MACHFG,  CONTFG,  SIGNAT,  RAYTRC, 

1  SCRPAO,  SCRPSF,  SCRALL,  GPCPFL,  FFT, GPCPMH , GPCPBM 

CHARACTERVO  TITLE 
CHARACTER*6  ARCRFT(S.IO) 

CHARACTERM6  MSSWS(5,10) 

CHARACTER'10  SITES<5,20) 

CHARACTER'S  TA1LNM(5,10) 

OPEN ( 76 , F I LE* ' HOLDVAR 1 , STATUS* ' UNKNOWN 1 ) 

REWIN0(76) 

READ(76, FMT*' (A) 1 )  TITLE 
DO  10  I  *  1,  5 

REA0(76,  FMT*'  (A)  *  )  (ARCRFTd  ,  J),  J=1 , 10) 

REA0(76, FMT*' (A) 1 )  (MSSNSCI , J), J*1 , 10) 

READ(76, FMT*1 (A) ' )  (SITESCI , J), J*1 ,20) 

READ(76,  FMT*'  (A) 1 )  (TAILNMd  ,J),  J*1 , 10) 
READ(76,FMT*'(I8)')  (ENTIMEd  ,  J),J*1 , 10) 

READ(76,FMT*'  <  18) '  )  (ENDATEd  ,J),  J*1 ,10) 

READ (76, FMT*1  (18) '  )  (STTIMEd ,  J),  J*1 ,10) 

READ(76, FMT*' ( 18) ' )  (STDATE( I , J), J*1 , 10) 

READ ( 76 , FMT  * 1 ( J  8) ‘ )  CONTYP(I) 

R£AO(76, FMT*' (F20.4) ' )  (CONTVLd ,  J) ,  J=1 ,20) 

10  CONTINUE 

REA0(76, FMT=' (5L1 ) 1 )  STATFG,  BOOMFG,  MACHFG,  CONTFG,  FFT 
READ ( 76, FMT* 1 (6L1 ) ' )  SIGNAT,  RAYTRC,  SCRPAO,  SCRPSF,  SCRALL 
1  GPCPFL 

READ (76, FMT*' (3F20.4) ' )  BOOMVL,  MACHVL,  WIDTH 
READ ( 76 , FMT  * ' (2L 1 , 1 8) ' )  GPCPMH,  GPCPBM,  NUMREP 
C 

C-  CALL  THE  DIRVER 


